packages feed

ghc-lib 0.20200205 → 0.20200301

raw patch · 413 files changed

+77624/−75978 lines, 413 filesdep ~ghc-lib-parser

Dependency ranges changed: ghc-lib-parser

This diff is very large; some files are shown as “too large to diff”. Download the raw patch for the complete diff.

Files

+ compiler/GHC.hs view
@@ -0,0 +1,1743 @@+{-# 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,+        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++        -- ** 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,+        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,++        -- *** 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(..),+        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 GhcPrelude 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 TcRnMonad        ( finalSafeMode, fixSafeInstances, initIfaceTcRn )+import GHC.Iface.Load   ( loadSysInterface )+import TcRnTypes+import Predicate+import GHC.Driver.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 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 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 FastString+import qualified Parser+import Lexer+import ApiAnnotation+import qualified GHC.LanguageExtensions as LangExt+import NameEnv+import GHC.Core.FVs     ( 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 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+import Control.Concurrent+import Control.Applicative ((<|>))++import Maybes+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.+  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<size> 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+          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+-- <http://hackage.haskell.org/package/ghc-paths>.++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'' <- liftIO $ interpretPackageEnv dflags'+  (dflags''', preload) <- liftIO $ initPackages dflags''++  -- Interpreter+  interp  <- if gopt Opt_ExternalInterpreter dflags+    then do+         let+           prog = pgm_i dflags ++ flavour+           flavour+             | WayProf `elem` ways dflags = "-prof"+             | WayDyn `elem` ways dflags  = "-dyn"+             | otherwise                  = ""+           msg = text "Starting " <> text prog+         tr <- if verbosity dflags >= 3+                then return (logInfo dflags (defaultDumpStyle dflags) msg)+                else return (pure ())+         let+          conf = IServConfig+            { iservConfProgram = prog+            , iservConfOpts    = getOpts dflags opt_i+            , iservConfHook    = createIservProcessHook (hooks dflags)+            , iservConfTrace   = tr+            }+         s <- liftIO $ newMVar (IServPending conf)+         return (Just (ExternalInterp (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+  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+-- 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+-- '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+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 (unitInfoMap (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 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 = 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 $ 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)++    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"
+ compiler/GHC/ByteCode/Asm.hs view
@@ -0,0 +1,566 @@+{-# 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 GhcPrelude++import GHC.ByteCode.Instr+import GHC.ByteCode.InfoTable+import GHC.ByteCode.Types+import GHCi.RemoteTypes+import GHC.Runtime.Interpreter++import GHC.Driver.Types+import Name+import NameSet+import Literal+import TyCon+import FastString+import GHC.StgToCmm.Layout     ( ArgRep(..) )+import GHC.Runtime.Heap.Layout+import GHC.Driver.Session+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 = 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 (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 "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 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
+ compiler/GHC/ByteCode/InfoTable.hs view
@@ -0,0 +1,76 @@+{-# 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 GhcPrelude++import GHC.ByteCode.Types+import GHC.Runtime.Interpreter+import GHC.Driver.Session+import GHC.Driver.Types+import Name             ( Name, getName )+import NameEnv+import DataCon          ( DataCon, dataConRepArgTys, dataConIdentity )+import TyCon            ( TyCon, tyConFamilySize, isDataTyCon, tyConDataCons )+import GHC.Types.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)
+ compiler/GHC/ByteCode/Instr.hs view
@@ -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 GhcPrelude++import GHC.ByteCode.Types+import GHCi.RemoteTypes+import GHCi.FFI (C_ffi_cif)+import GHC.StgToCmm.Layout     ( ArgRep(..) )+import GHC.Core.Ppr+import Outputable+import FastString+import Name+import Unique+import Id+import GHC.Core+import Literal+import DataCon+import VarSet+import PrimOp+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 "<cc>"++-- -----------------------------------------------------------------------------+-- 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
+ compiler/GHC/ByteCode/Linker.hs view
@@ -0,0 +1,184 @@+{-# 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 GhcPrelude++import GHCi.RemoteTypes+import GHCi.ResolvedBCO+import GHCi.BreakArray+import SizedSeq++import GHC.Runtime.Interpreter+import GHC.ByteCode.Types+import GHC.Driver.Types+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 "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 (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+    ]
compiler/GHC/Cmm/CallConv.hs view
@@ -8,11 +8,11 @@ import GhcPrelude  import GHC.Cmm.Expr-import GHC.Runtime.Layout+import GHC.Runtime.Heap.Layout import GHC.Cmm (Convention(..)) import GHC.Cmm.Ppr () -- For Outputable instances -import DynFlags+import GHC.Driver.Session import GHC.Platform import Outputable
compiler/GHC/Cmm/CommonBlockElim.hs view
@@ -300,7 +300,7 @@              foldr blockCons code (map CmmTick ticks)  -- Group by [Label]--- See Note [Compressed TrieMap] in coreSyn/TrieMap about the usage of GenMap.+-- 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]))
compiler/GHC/Cmm/Dataflow.hs view
@@ -43,13 +43,14 @@ 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 family   Fact (x :: Extensibility) f :: Type type instance Fact C f = FactBase f type instance Fact O f = f
compiler/GHC/Cmm/DebugBlock.hs view
@@ -31,7 +31,7 @@ import GHC.Cmm.CLabel import GHC.Cmm import GHC.Cmm.Utils-import CoreSyn+import GHC.Core import FastString      ( nilFS, mkFastString ) import Module import Outputable@@ -161,7 +161,7 @@                 = DebugBlock { dblProcedure    = g_entry graph                              , dblLabel        = label                              , dblCLabel       = case info of-                                 Just (Statics infoLbl _)   -> infoLbl+                                 Just (RawCmmStatics infoLbl _) -> infoLbl                                  Nothing                                    | g_entry graph == label -> entryLbl                                    | otherwise              -> blockLbl label
compiler/GHC/Cmm/Graph.hs view
@@ -31,11 +31,11 @@ import GHC.Cmm.Dataflow.Block import GHC.Cmm.Dataflow.Graph import GHC.Cmm.Dataflow.Label-import DynFlags+import GHC.Driver.Session import FastString import ForeignCall import OrdList-import GHC.Runtime.Layout (ByteOff)+import GHC.Runtime.Heap.Layout (ByteOff) import UniqSupply import Util import Panic
compiler/GHC/Cmm/Info.hs view
@@ -2,7 +2,6 @@ module GHC.Cmm.Info (   mkEmptyContInfoTable,   cmmToRawCmm,-  mkInfoTable,   srtEscape,    -- info table accessors@@ -39,7 +38,7 @@ import GHC.Cmm import GHC.Cmm.Utils import GHC.Cmm.CLabel-import GHC.Runtime.Layout+import GHC.Runtime.Heap.Layout import GHC.Data.Bitmap import Stream (Stream) import qualified Stream@@ -47,7 +46,7 @@  import GHC.Platform import Maybes-import DynFlags+import GHC.Driver.Session import ErrUtils (withTimingSilent) import Panic import UniqSupply@@ -67,11 +66,11 @@                  , cit_srt  = Nothing                  , cit_clo  = Nothing } -cmmToRawCmm :: DynFlags -> Stream IO CmmGroup a+cmmToRawCmm :: DynFlags -> Stream IO CmmGroupSRTs a             -> IO (Stream IO RawCmmGroup a) cmmToRawCmm dflags cmms   = do { uniqs <- mkSplitUniqSupply 'i'-       ; let do_one :: UniqSupply -> [CmmDecl] -> IO (UniqSupply, [RawCmmDecl])+       ; 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")@@ -117,9 +116,8 @@ -- --  * 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 :: DynFlags -> CmmDeclSRTs -> UniqSM [RawCmmDecl]+mkInfoTable _ (CmmData sec dat) = return [CmmData sec dat]  mkInfoTable dflags proc@(CmmProc infos entry_lbl live blocks)   --@@ -169,7 +167,7 @@         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 $+     return (top_decls, (lbl, RawCmmStatics info_lbl $ map CmmStaticLit $                               reverse rel_extra_bits ++ rel_std_info))  -----------------------------------------------------@@ -423,7 +421,7 @@        ; (cd_lit, cd_decl) <- newStringLit cd        ; return ((td_lit,cd_lit), [td_decl,cd_decl]) } -newStringLit :: ByteString -> UniqSM (CmmLit, GenCmmDecl CmmStatics info stmt)+newStringLit :: ByteString -> UniqSM (CmmLit, GenCmmDecl RawCmmStatics info stmt) newStringLit bytes   = do { uniq <- getUniqueM        ; return (mkByteStringCLit (mkStringLitLabel uniq) bytes) }
compiler/GHC/Cmm/Info/Build.hs view
@@ -1,14 +1,17 @@ {-# LANGUAGE GADTs, BangPatterns, RecordWildCards,-    GeneralizedNewtypeDeriving, NondecreasingIndentation, TupleSections #-}+    GeneralizedNewtypeDeriving, NondecreasingIndentation, TupleSections,+    ScopedTypeVariables, OverloadedStrings #-}  module GHC.Cmm.Info.Build-  ( CAFSet, CAFEnv, cafAnal-  , doSRTs, ModuleSRTInfo, emptySRT+  ( CAFSet, CAFEnv, cafAnal, cafAnalData+  , doSRTs, ModuleSRTInfo (..), emptySRT+  , SRTMap, srtMapNonCAFs   ) where  import GhcPrelude hiding (succ)  import Id+import IdInfo import GHC.Cmm.BlockId import GHC.Cmm.Dataflow.Block import GHC.Cmm.Dataflow.Graph@@ -21,23 +24,24 @@ import GHC.Cmm.CLabel import GHC.Cmm import GHC.Cmm.Utils-import DynFlags+import GHC.Driver.Session import Maybes import Outputable-import GHC.Runtime.Layout+import GHC.Runtime.Heap.Layout import UniqSupply import CostCentre import GHC.StgToCmm.Heap  import Control.Monad-import Data.Map (Map)-import qualified Data.Map as Map+import Data.Map.Strict (Map)+import qualified Data.Map.Strict 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+import Data.List (unzip4) +import NameSet  {- Note [SRTs] @@ -183,7 +187,64 @@    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 ^^^^^^^^^^^^^ @@ -372,7 +433,7 @@ type CAFEnv = LabelMap CAFSet  mkCAFLabel :: CLabel -> CAFLabel-mkCAFLabel lbl = CAFLabel (toClosureLbl lbl)+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.@@ -382,6 +443,35 @@ -- --------------------------------------------------------------------- -- 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,@@ -412,17 +502,24 @@  cafTransfers :: LabelSet -> Label -> CLabel -> TransferFun CAFSet cafTransfers contLbls entry topLbl-  (BlockCC eNode middle xNode) fBase =-    let joined = cafsInNode xNode $! live'+  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 (add topLbl Set.empty)+          | 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@@ -432,18 +529,27 @@           = lookupFact s fBase          cafsInNode :: CmmNode e x -> CAFSet -> CAFSet-        cafsInNode node set = foldExpDeep addCaf node set+        cafsInNode node set = foldExpDeep addCafExpr node set -        addCaf expr !set =+        addCafExpr :: CmmExpr -> Set CAFLabel -> Set CAFLabel+        addCafExpr 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+            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   -- -----------------------------------------------------------------------------@@ -460,17 +566,24 @@     -- 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:" <+> ppr dedupSRTs <+> ppr flatSRTs+    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 }+    , flatSRTs = Map.empty+    , moduleSRTMap = Map.empty+    }  -- ----------------------------------------------------------------------------- -- Constructing SRTs@@ -489,41 +602,72 @@  -} +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 -> [(Label, CAFLabel)]-getLabelledBlocks (CmmData _ _) = []+getLabelledBlocks :: CmmDecl -> [(SomeLabel, CAFLabel)]+getLabelledBlocks (CmmData _ (CmmStaticsRaw _ _)) =+  []+getLabelledBlocks (CmmData _ (CmmStatics lbl _ _ _)) =+  [ (DeclLabel lbl, mkCAFLabel lbl) ] getLabelledBlocks (CmmProc top_info _ _ _) =-  [ (blockId, mkCAFLabel (cit_lbl 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 (Label, CAFLabel, Set CAFLabel)]-depAnalSRTs cafEnv decls =-  srtTrace "depAnalSRTs" (ppr graph) graph+  -> [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.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] ]+  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@@ -552,7 +696,7 @@   , Just (id, _) <- [cit_clo info]   , let rep = cit_rep info   , isStaticRep rep && isFunRep rep-  , let lbl = mkLocalClosureLabel (idName id) (idCafInfo id)+  , let !lbl = mkLocalClosureLabel (idName id) (idCafInfo id)   ]  @@ -565,11 +709,21 @@ --     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 Names not in the set are CAFFY.+srtMapNonCAFs :: SRTMap -> NameSet+srtMapNonCAFs srtMap = 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) =-  Map.findWithDefault (Just (SRTEntry (toClosureLbl l))) lbl srtMap-+    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.@@ -578,16 +732,33 @@   :: DynFlags   -> ModuleSRTInfo   -> [(CAFEnv, [CmmDecl])]-  -> IO (ModuleSRTInfo, [CmmDecl])+  -> [(CAFSet, CmmDecl)]+  -> IO (ModuleSRTInfo, [CmmDeclSRTs]) -doSRTs dflags moduleSRTInfo tops = do+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 (cafEnvs, declss) = unzip tops-      cafEnv = mapUnions cafEnvs-      decls = concat declss+  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@@ -597,56 +768,90 @@   -- to do this we need to process blocks before things that depend on   -- them.   let-    sccs = depAnalSRTs cafEnv decls+    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 ::-        [ ( [CmmDecl]              -- generated SRTs+        [ ( [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, _srtMap), moduleSRTInfo') =++      (result, moduleSRTInfo') =         initUs_ us $-        flip runStateT moduleSRTInfo $-        flip runStateT Map.empty $ do-          nonCAFs <- mapM (doSCC dflags staticFuns) sccs+        flip runStateT moduleSRTInfo $ do+          nonCAFs <- mapM (doSCC dflags staticFuns static_data) sccs           cAFs <- forM cafsWithSRTs $ \(l, cafLbl, cafs) ->-            oneSRT dflags staticFuns [l] [cafLbl] True{-is a CAF-} cafs+            oneSRT dflags staticFuns [BlockLabel l] [cafLbl]+                   True{-is a CAF-} cafs static_data           return (nonCAFs ++ cAFs) -      (declss, pairs, funSRTs) = unzip3 result+      (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)-    decls' = concatMap (updInfoSRTs dflags srtFieldMap funSRTMap) decls+    has_caf_refs' = or has_caf_refs+    decls' =+      concatMap (updInfoSRTs dflags srtFieldMap funSRTMap has_caf_refs') decls -  return (moduleSRTInfo', concat declss ++ 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 analysed by oneSRT, declare it non-CAFFY 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-  -> SCC (Label, CAFLabel, Set CAFLabel)-  -> StateT SRTMap-        (StateT ModuleSRTInfo UniqSM)-        ( [CmmDecl]              -- generated SRTs+  -> 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  (AcyclicSCC (l, cafLbl, cafs)) =-  oneSRT dflags staticFuns [l] [cafLbl] False cafs+doSCC dflags staticFuns static_data (AcyclicSCC (l, cafLbl, cafs)) =+  oneSRT dflags staticFuns [l] [cafLbl] False cafs static_data -doSCC dflags staticFuns (CyclicSCC nodes) = do+doSCC dflags staticFuns static_data (CyclicSCC nodes) = do   -- build a single SRT for the whole cycle, see Note [recursive SRTs]-  let (blockids, lbls, cafsets) = unzip3 nodes+  let (lbls, caf_lbls, cafsets) = unzip3 nodes       cafs = Set.unions cafsets-  oneSRT dflags staticFuns blockids lbls False cafs+  oneSRT dflags staticFuns lbls caf_lbls False cafs static_data   {- Note [recursive SRTs]@@ -677,34 +882,40 @@ oneSRT   :: DynFlags   -> LabelMap CLabel            -- which blocks are static function entry points-  -> [Label]                    -- blocks in this set+  -> [SomeLabel]                -- 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+  -> 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 blockids lbls isCAF cafs = do-  srtMap <- get-  topSRT <- lift get+oneSRT dflags staticFuns lbls caf_lbls isCAF cafs static_data = do+  topSRT <- get+   let+    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 (mkCAFLabel . fst) xs)+        ((l,b):xs) -> (Just (l,b), map 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)+    -- Remove recursive references from the SRT+    nonRec :: Set CAFLabel+    nonRec = cafs `Set.difference` Set.fromList caf_lbls -    -- First resolve all the CAFLabels to SRTEntries-    -- Implements the [Inline] optimisation.+    -- 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.@@ -714,10 +925,21 @@      -- Remove SRTEntries that are also in an SRT that we refer to.     -- Implements the [Filter] optimisation.-    filtered = Set.difference (Set.fromList resolved) allBelow+    filtered0 = Set.fromList resolved `Set.difference` allBelow -  srtTrace "oneSRT:"-     (ppr cafs <+> ppr resolved <+> ppr allBelow <+> ppr filtered) $ return ()+  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@@ -726,86 +948,124 @@     -- 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 =-      when (not isCAF && (not isStaticFun || isNothing srtEntry)) $ do-        let newSRTMap = Map.fromList [(cafLbl, srtEntry) | cafLbl <- lbls]-        put (Map.union newSRTMap srtMap)+      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 -  case Set.toList filtered of-    [] -> do-      srtTrace "oneSRT: empty" (ppr lbls) $ return ()-      updateSRTMap Nothing-      return ([], [], [])+    allStaticData =+      all (\(CAFLabel clbl) -> Set.member clbl static_data) caf_lbls -    -- [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)+  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 -        -- 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+      -- [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) -        -- 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, [])+          -- 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 -    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)+          -- 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-        ( [CmmDecl]    -- The SRT object(s)-        , SRTEntry     -- label to use in the info table+        ( [CmmDeclSRTs] -- The SRT object(s)+        , SRTEntry      -- label to use in the info table         ) buildSRTChain _ [] = panic "buildSRT: empty" buildSRTChain dflags cafSet =@@ -821,7 +1081,7 @@     mAX_SRT_SIZE = 16  -buildSRT :: DynFlags -> [SRTEntry] -> UniqSM (CmmDecl, SRTEntry)+buildSRT :: DynFlags -> [SRTEntry] -> UniqSM (CmmDeclSRTs, SRTEntry) buildSRT dflags refs = do   id <- getUniqueM   let@@ -835,20 +1095,30 @@         [] -- 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-  -> [CmmDecl]+  -> [CmmDeclSRTs] -updInfoSRTs dflags srt_env funSRTEnv (CmmProc top_info top_l live g)+updInfoSRTs _ _ _ _ (CmmData s (CmmStaticsRaw lbl statics))+  = [CmmData s (RawCmmStatics lbl statics)]++updInfoSRTs dflags _ _ caffy (CmmData s (CmmStatics lbl itbl ccs payload))+  = [CmmData s (RawCmmStatics 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@@ -858,7 +1128,7 @@     -- 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 :: Maybe (CmmInfoTable, CmmDeclSRTs)     maybeStaticClosure       | Just info_tbl@CmmInfoTable{..} <-            mapLookup (g_entry g) (info_tbls top_info)@@ -873,20 +1143,20 @@             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+          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) (idCafInfo id)+          lbl = mkLocalClosureLabel (idName id) caf_info         in           Just (newInfo, mkDataLits (Section Data lbl) lbl fields)       | otherwise = Nothing -updInfoSRTs _ _ _ t = [t] - srtTrace :: String -> SDoc -> b -> b -- srtTrace = pprTrace srtTrace _ _ b = b++srtTraceM :: Applicative f => String -> SDoc -> f ()+srtTraceM str doc = srtTrace str doc (pure ())
compiler/GHC/Cmm/LayoutStack.hs view
@@ -18,7 +18,7 @@ import ForeignCall import GHC.Cmm.Liveness import GHC.Cmm.ProcPoint-import GHC.Runtime.Layout+import GHC.Runtime.Heap.Layout import GHC.Cmm.Dataflow.Block import GHC.Cmm.Dataflow.Collections import GHC.Cmm.Dataflow@@ -29,7 +29,7 @@ import UniqFM import Util -import DynFlags+import GHC.Driver.Session import FastString import Outputable hiding ( isEmpty ) import qualified Data.Set as Set
compiler/GHC/Cmm/Lexer.x view
@@ -185,7 +185,7 @@ -- ----------------------------------------------------------------------------- -- Lexer actions -type Action = RealSrcSpan -> StringBuffer -> Int -> PD (RealLocated CmmToken)+type Action = PsSpan -> StringBuffer -> Int -> PD (PsLocated CmmToken)  begin :: Int -> Action begin code _span _str _len = do liftP (pushLexState code); lexToken@@ -290,7 +290,7 @@ -- Line pragmas  setLine :: Int -> Action-setLine code span buf len = do+setLine code (PsSpan span _) buf len = do   let line = parseUnsignedInteger buf len 10 octDecDigit   liftP $ do     setSrcLoc (mkRealSrcLoc (srcSpanFile span) (fromIntegral line - 1) 1)@@ -300,7 +300,7 @@   lexToken  setFile :: Int -> Action-setFile code span buf len = do+setFile code (PsSpan span _) buf len = do   let file = lexemeToFastString (stepOn buf) (len-2)   liftP $ do     setSrcLoc (mkRealSrcLoc file (srcSpanEndLine span) (srcSpanEndCol span))@@ -315,23 +315,23 @@ cmmlex cont = do   (L span tok) <- lexToken   --trace ("token: " ++ show tok) $ do-  cont (L (RealSrcSpan span) tok)+  cont (L (mkSrcSpanPs span) tok) -lexToken :: PD (RealLocated CmmToken)+lexToken :: PD (PsLocated CmmToken) lexToken = do   inp@(loc1,buf) <- getInput   sc <- liftP getLexState   case alexScan inp sc of-    AlexEOF -> do let span = mkRealSrcSpan loc1 loc1+    AlexEOF -> do let span = mkPsSpan loc1 loc1                   liftP (setLastToken span 0)                   return (L span CmmT_EOF)-    AlexError (loc2,_) -> liftP $ failLocMsgP loc1 loc2 "lexical error"+    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 = mkRealSrcSpan loc1 end+        let span = mkPsSpan loc1 end         span `seq` liftP (setLastToken span len)         t span buf len @@ -339,7 +339,7 @@ -- Monad stuff  -- Stuff that Alex needs to know about our input type:-type AlexInput = (RealSrcLoc,StringBuffer)+type AlexInput = (PsLoc,StringBuffer)  alexInputPrevChar :: AlexInput -> Char alexInputPrevChar (_,s) = prevChar s '\n'@@ -357,7 +357,7 @@   | otherwise = b `seq` loc' `seq` s' `seq` Just (b, (loc', s'))   where c    = currentChar s         b    = fromIntegral $ ord $ c-        loc' = advanceSrcLoc loc c+        loc' = advancePsLoc loc c         s'   = stepOn s  getInput :: PD AlexInput
compiler/GHC/Cmm/Lint.hs view
@@ -23,7 +23,7 @@ import GHC.Cmm.Switch (switchTargetsToList) import GHC.Cmm.Ppr () -- For Outputable instances import Outputable-import DynFlags+import GHC.Driver.Session  import Control.Monad (ap)
compiler/GHC/Cmm/Liveness.hs view
@@ -14,7 +14,7 @@  import GhcPrelude -import DynFlags+import GHC.Driver.Session import GHC.Cmm.BlockId import GHC.Cmm import GHC.Cmm.Ppr.Expr () -- For Outputable instances
compiler/GHC/Cmm/Monad.hs view
@@ -1,5 +1,3 @@-{-# LANGUAGE CPP #-}- ----------------------------------------------------------------------------- -- A Parser monad with access to the 'DynFlags'. --@@ -12,14 +10,14 @@ module GHC.Cmm.Monad (     PD(..)   , liftP+  , failMsgPD   ) where  import GhcPrelude  import Control.Monad-import qualified Control.Monad.Fail as MonadFail -import DynFlags+import GHC.Driver.Session import Lexer  newtype PD a = PD { unPD :: DynFlags -> PState -> ParseResult a }@@ -33,16 +31,13 @@  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 +failMsgPD :: String -> PD a+failMsgPD = liftP . failMsgP+ returnPD :: a -> PD a returnPD = liftP . return @@ -51,9 +46,6 @@         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
compiler/GHC/Cmm/Opt.hs view
@@ -17,7 +17,7 @@  import GHC.Cmm.Utils import GHC.Cmm-import DynFlags+import GHC.Driver.Session import Util  import Outputable
compiler/GHC/Cmm/Parser.y view
@@ -219,7 +219,7 @@ import GHC.StgToCmm.Layout     hiding (ArgRep(..)) import GHC.StgToCmm.Ticky import GHC.StgToCmm.Bind  ( emitBlackHoleCode, emitUpdateFrame )-import CoreSyn            ( Tickish(SourceNote) )+import GHC.Core           ( Tickish(SourceNote) )  import GHC.Cmm.Opt import GHC.Cmm.Graph@@ -231,7 +231,7 @@ import GHC.Cmm.Lexer import GHC.Cmm.CLabel import GHC.Cmm.Monad-import GHC.Runtime.Layout+import GHC.Runtime.Heap.Layout import Lexer  import CostCentre@@ -242,7 +242,7 @@ import Unique import UniqFM import SrcLoc-import DynFlags+import GHC.Driver.Session import ErrUtils import StringBuffer import FastString@@ -394,7 +394,7 @@         : 'section' STRING '{' data_label statics '}'                 { do lbl <- $4;                      ss <- sequence $5;-                     code (emitDecl (CmmData (Section (section $2) lbl) (Statics lbl $ concat ss))) }+                     code (emitDecl (CmmData (Section (section $2) lbl) (CmmStaticsRaw lbl (concat ss)))) }  data_label :: { CmmParse CLabel }     : NAME ':'@@ -902,7 +902,7 @@ nameToMachOp :: FastString -> PD (Width -> MachOp) nameToMachOp name =   case lookupUFM machOps name of-        Nothing -> fail ("unknown primitive " ++ unpackFS name)+        Nothing -> failMsgPD ("unknown primitive " ++ unpackFS name)         Just m  -> return m  exprOp :: FastString -> [CmmParse CmmExpr] -> PD (CmmParse CmmExpr)@@ -1056,12 +1056,12 @@ parseSafety "safe"   = return PlaySafe parseSafety "unsafe" = return PlayRisky parseSafety "interruptible" = return PlayInterruptible-parseSafety str      = fail ("unrecognised safety: " ++ str)+parseSafety str      = failMsgPD ("unrecognised safety: " ++ str)  parseCmmHint :: String -> PD ForeignHint parseCmmHint "ptr"    = return AddrHint parseCmmHint "signed" = return SignedHint-parseCmmHint str      = fail ("unrecognised hint: " ++ str)+parseCmmHint str      = failMsgPD ("unrecognised hint: " ++ str)  -- labels are always pointers, so we might as well infer the hint inferCmmHint :: CmmExpr -> ForeignHint@@ -1088,7 +1088,7 @@ stmtMacro :: FastString -> [CmmParse CmmExpr] -> PD (CmmParse ()) stmtMacro fun args_code = do   case lookupUFM stmtMacros fun of-    Nothing -> fail ("unknown macro: " ++ unpackFS fun)+    Nothing -> failMsgPD ("unknown macro: " ++ unpackFS fun)     Just fcode -> return $ do         args <- sequence args_code         code (fcode args)@@ -1175,7 +1175,7 @@ staticClosure pkg cl_label info payload   = do dflags <- getDynFlags        let lits = mkStaticClosure dflags (mkCmmInfoLabel pkg info) dontCareCCS payload [] [] []-       code $ emitDataLits (mkCmmDataLabel pkg cl_label) lits+       code $ emitRawDataLits (mkCmmDataLabel pkg cl_label) lits  foreignCall         :: String@@ -1189,7 +1189,7 @@   = do  conv <- case conv_string of           "C" -> return CCallConv           "stdcall" -> return StdCallConv-          _ -> fail ("unknown calling convention: " ++ conv_string)+          _ -> failMsgPD ("unknown calling convention: " ++ conv_string)         return $ do           dflags <- getDynFlags           results <- sequence results_code@@ -1265,7 +1265,7 @@         -> PD (CmmParse ()) primCall results_code name args_code   = case lookupUFM callishMachOps name of-        Nothing -> fail ("unknown primitive " ++ unpackFS name)+        Nothing -> failMsgPD ("unknown primitive " ++ unpackFS name)         Just f  -> return $ do                 results <- sequence results_code                 args <- sequence args_code@@ -1356,7 +1356,7 @@ withSourceNote a b parse = do   name <- getName   case combineSrcSpans (getLoc a) (getLoc b) of-    RealSrcSpan span -> code (emitTick (SourceNote span name)) >> parse+    RealSrcSpan span _ -> code (emitTick (SourceNote span name)) >> parse     _other           -> parse  -- -----------------------------------------------------------------------------
compiler/GHC/Cmm/Pipeline.hs view
@@ -1,4 +1,6 @@ {-# LANGUAGE BangPatterns #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE TupleSections #-}  module GHC.Cmm.Pipeline (   -- | Converts C-- with an implicit stack and native C-- calls into@@ -21,12 +23,13 @@ import GHC.Cmm.Dataflow.Collections  import UniqSupply-import DynFlags+import GHC.Driver.Session import ErrUtils-import HscTypes+import GHC.Driver.Types import Control.Monad import Outputable import GHC.Platform+import Data.Either (partitionEithers)  ----------------------------------------------------------------------------- -- | Top level driver for C-- pipeline@@ -37,14 +40,15 @@            -- 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--+ -> 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 -     (srtInfo, cmms) <- {-# SCC "doSRTs" #-} doSRTs dflags srtInfo tops+     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)@@ -54,8 +58,8 @@          dflags = hsc_dflags hsc_env -cpsTop :: HscEnv -> CmmDecl -> IO (CAFEnv, [CmmDecl])-cpsTop _ p@(CmmData {}) = return (mapEmpty, [p])+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 ----------------------------------@@ -85,7 +89,9 @@        dump Opt_D_dump_cmm_switch "Post switch plan" g         ----------- Proc points --------------------------------------------------       let call_pps = {-# SCC "callProcPoints" #-} callProcPoints g+       let+         call_pps :: ProcPointSet -- LabelMap+         call_pps = {-# SCC "callProcPoints" #-} callProcPoints g        proc_points <-           if splitting_proc_points              then do@@ -144,7 +150,7 @@             -- See Note [unreachable blocks]        dumps Opt_D_dump_cmm_cfg "Post control-flow optimisations" g -       return (cafEnv, g)+       return (Left (cafEnv, g))    where dflags = hsc_dflags hsc_env         platform = targetPlatform dflags
compiler/GHC/Cmm/Ppr.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE GADTs, TypeFamilies, FlexibleContexts, FlexibleInstances #-}+{-# LANGUAGE LambdaCase #-} {-# OPTIONS_GHC -fno-warn-orphans #-}  ----------------------------------------------------------------------------@@ -45,7 +46,6 @@ import GHC.Cmm import GHC.Cmm.Utils import GHC.Cmm.Switch-import DynFlags import FastString import Outputable import GHC.Cmm.Ppr.Decl@@ -181,22 +181,22 @@ pprNode node = pp_node <+> pp_debug   where     pp_node :: SDoc-    pp_node = sdocWithDynFlags $ \dflags -> case node of+    pp_node = 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+      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 -> ppUnless (gopt Opt_SuppressTicks dflags) $-                   text "//tick" <+> ppr t+      CmmTick t -> ppUnlessOption sdocSuppressTicks+                     (text "//tick" <+> ppr t)        -- unwind reg = expr;       CmmUnwind regs ->
compiler/GHC/Cmm/Ppr/Decl.hs view
@@ -43,7 +43,7 @@ import GHC.Cmm.Ppr.Expr import GHC.Cmm -import DynFlags+import GHC.Driver.Session import Outputable import FastString @@ -54,13 +54,13 @@   pprCmms :: (Outputable info, Outputable g)-        => [GenCmmGroup CmmStatics info g] -> SDoc+        => [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 CmmStatics info g] -> IO ()+          => DynFlags -> Handle -> [GenCmmGroup RawCmmStatics info g] -> IO () writeCmms dflags handle cmms = printForC dflags handle (pprCmms cmms)  -----------------------------------------------------------------------------@@ -72,6 +72,9 @@ instance Outputable CmmStatics where     ppr = pprStatics +instance Outputable RawCmmStatics where+    ppr = pprRawStatics+ instance Outputable CmmStatic where     ppr = pprStatic @@ -136,8 +139,14 @@ --      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)+pprStatics (CmmStatics lbl itbl ccs payload) =+  ppr lbl <> colon <+> ppr itbl <+> ppr ccs <+> ppr payload+pprStatics (CmmStaticsRaw lbl ds) = pprRawStatics (RawCmmStatics lbl ds)++pprRawStatics :: RawCmmStatics -> SDoc+pprRawStatics (RawCmmStatics lbl ds) = vcat ((ppr lbl <> colon) : map ppr ds)  pprStatic :: CmmStatic -> SDoc pprStatic s = case s of
compiler/GHC/Cmm/Ppr/Expr.hs view
@@ -31,8 +31,9 @@ -- -- 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     )@@ -43,7 +44,6 @@ import GHC.Cmm.Expr  import Outputable-import DynFlags  import Data.Maybe import Numeric ( fromRat )@@ -227,18 +227,17 @@ -- We only print the type of the local reg if it isn't wordRep -- pprLocalReg :: LocalReg -> SDoc-pprLocalReg (LocalReg uniq rep) = sdocWithDynFlags $ \dflags ->+pprLocalReg (LocalReg uniq rep) = --   = ppr rep <> char '_' <> ppr uniq -- Temp Jan08-    char '_' <> pprUnique dflags uniq <>+    char '_' <> pprUnique 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+     pprUnique unique = sdocOption sdocSuppressUniques $ \case+       True  -> text "_locVar_"+       False -> ppr unique      ptr = empty          --if isGcPtrType rep          --      then doubleQuotes (text "ptr")
compiler/GHC/Cmm/ProcPoint.hs view
@@ -11,7 +11,7 @@  import GhcPrelude hiding (last, unzip, succ, zip) -import DynFlags+import GHC.Driver.Session import GHC.Cmm.BlockId import GHC.Cmm.CLabel import GHC.Cmm
compiler/GHC/Cmm/Sink.hs view
@@ -16,7 +16,7 @@ import GHC.Platform.Regs import GHC.Platform (isARM, platformArch) -import DynFlags+import GHC.Driver.Session import Unique import UniqFM
compiler/GHC/Cmm/Switch/Implement.hs view
@@ -12,7 +12,8 @@ import GHC.Cmm.Utils import GHC.Cmm.Switch import UniqSupply-import DynFlags+import GHC.Driver.Session+import MonadUtils (concatMapM)  -- -- This module replaces Switch statements as generated by the Stg -> Cmm@@ -35,7 +36,7 @@     -- Switch generation done by backend (LLVM/C)     | targetSupportsSwitch (hscTarget dflags) = return g     | otherwise = do-    blocks' <- concat `fmap` mapM (visitSwitches dflags) (toBlockList g)+    blocks' <- concatMapM (visitSwitches dflags) (toBlockList g)     return $ ofBlockList (g_entry g) blocks'  visitSwitches :: DynFlags -> CmmBlock -> UniqSM [CmmBlock]
compiler/GHC/Cmm/Utils.hs view
@@ -75,12 +75,12 @@ import TyCon    ( PrimRep(..), PrimElemRep(..) ) import GHC.Types.RepType  ( UnaryType, SlotTy (..), typePrimRep1 ) -import GHC.Runtime.Layout+import GHC.Runtime.Heap.Layout import GHC.Cmm import GHC.Cmm.BlockId import GHC.Cmm.CLabel import Outputable-import DynFlags+import GHC.Driver.Session import Unique import GHC.Platform.Regs @@ -192,22 +192,22 @@ mkWordCLit dflags wd = CmmInt wd (wordWidth dflags)  mkByteStringCLit-  :: CLabel -> ByteString -> (CmmLit, GenCmmDecl CmmStatics info stmt)+  :: CLabel -> ByteString -> (CmmLit, GenCmmDecl RawCmmStatics 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])+  = (CmmLabel lbl, CmmData (Section sec lbl) $ RawCmmStatics 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+mkDataLits :: Section -> CLabel -> [CmmLit] -> GenCmmDecl RawCmmStatics info stmt -- Build a data-segment data block mkDataLits section lbl lits-  = CmmData section (Statics lbl $ map CmmStaticLit lits)+  = CmmData section (RawCmmStatics lbl $ map CmmStaticLit lits) -mkRODataLits :: CLabel -> [CmmLit] -> GenCmmDecl CmmStatics info stmt+mkRODataLits :: CLabel -> [CmmLit] -> GenCmmDecl RawCmmStatics info stmt -- Build a read-only data block mkRODataLits lbl lits   = mkDataLits section lbl lits
+ compiler/GHC/CmmToAsm.hs view
@@ -0,0 +1,1236 @@+-- -----------------------------------------------------------------------------+--+-- (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 GhcPrelude++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 GraphColor                             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 AsmUtils+import GHC.CmmToAsm.Reg.Target+import GHC.Platform+import GHC.CmmToAsm.BlockLayout as BlockLayout+import Config+import GHC.CmmToAsm.Instr+import GHC.CmmToAsm.PIC+import GHC.Platform.Reg+import GHC.CmmToAsm.Monad+import GHC.CmmToAsm.CFG+import GHC.CmmToAsm.Dwarf+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 UniqFM+import UniqSupply+import GHC.Driver.Session+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"+      ArchARM64     -> 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, RawCmmStatics)+                                  X86.Instr.Instr X86.Instr.JumpDest+x86NcgImpl dflags+ = (x86_64NcgImpl dflags)++x86_64NcgImpl :: DynFlags -> NcgImpl (Alignment, RawCmmStatics)+                                  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 RawCmmStatics 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 RawCmmStatics 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"+                  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+        printSDocLn Pretty.LeftMode dflags h (mkCodeStyle AsmStyle)+                $ makeImportsDoc dflags (concat (ngs_imports ngs))+        return us'+  where+    dump_stats = dumpAction dflags (mkDumpStyle dflags 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 Debug.+              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++        {-# SCC "pprNativeCode" #-} bufLeftRenderSDoc dflags h+                                      (mkCodeStyle AsmStyle) 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 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" 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 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"+                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 (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"+                        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 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"+                        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 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"+                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 (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 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 "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+                              (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 :: 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
+ compiler/GHC/CmmToAsm/BlockLayout.hs view
@@ -0,0 +1,895 @@+--+-- Copyright (c) 2018 Andreas Klebinger+--++{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE FlexibleContexts #-}++module GHC.CmmToAsm.BlockLayout+    ( sequenceTop )+where++#include "HsVersions.h"+import GhcPrelude++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.Driver.Session (gopt, GeneralFlag(..), DynFlags, backendMaintainsCfg)+import UniqFM+import Util+import Unique++import Digraph+import Outputable+import Maybes++-- DEBUGGING ONLY+--import GHC.Cmm.DebugBlock+--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 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:+    <infoTable>+    B: goto C:+    <infoTable>+    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.+    <info table>+    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.++-}+++-- | 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+    = -- 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+            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 small if we jump over an info table+                = Just (CfgEdge from to edgeInfo { edgeWeight = w/8 })+                | otherwise+                = Just edge++        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 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)
+ compiler/GHC/CmmToAsm/CFG.hs view
@@ -0,0 +1,1320 @@+--+-- Copyright (c) 2018 Andreas Klebinger+--++{-# LANGUAGE TypeFamilies, ScopedTypeVariables #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DataKinds #-}++module GHC.CmmToAsm.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 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 Util+import Digraph+import Maybes++import 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 Outputable+-- DEBUGGING ONLY+--import GHC.Cmm.DebugBlock+--import 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++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 <edgeData>)+-- 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. (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 laid 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 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 :: 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 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
+ compiler/GHC/CmmToAsm/CFG/Dominators.hs view
@@ -0,0 +1,597 @@+{-# LANGUAGE RankNTypes, BangPatterns, FlexibleContexts, Strict #-}
+
+{- |
+  Module      :  Dominators
+  Copyright   :  (c) Matt Morrow 2009
+  License     :  BSD3
+  Maintainer  :  <morrow@moonpatio.com>
+  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 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)
+
+ compiler/GHC/CmmToAsm/CPrim.hs view
@@ -0,0 +1,133 @@+-- | Generating C symbol names emitted by the compiler.+module GHC.CmmToAsm.CPrim+    ( atomicReadLabel+    , atomicWriteLabel+    , atomicRMWLabel+    , cmpxchgLabel+    , popCntLabel+    , pdepLabel+    , pextLabel+    , bSwapLabel+    , bRevLabel+    , clzLabel+    , ctzLabel+    , word2FloatLabel+    ) where++import GhcPrelude++import GHC.Cmm.Type+import GHC.Cmm.MachOp+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)
+ compiler/GHC/CmmToAsm/Dwarf.hs view
@@ -0,0 +1,269 @@+module GHC.CmmToAsm.Dwarf (+  dwarfGen+  ) where++import GhcPrelude++import GHC.Cmm.CLabel+import GHC.Cmm.Expr    ( GlobalReg(..) )+import Config          ( cProjectName, cProjectVersion )+import GHC.Core        ( Tickish(..) )+import GHC.Cmm.DebugBlock+import GHC.Driver.Session+import Module+import Outputable+import GHC.Platform+import Unique+import UniqSupply++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++  -- 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+    ]
+ compiler/GHC/CmmToAsm/Dwarf/Constants.hs view
@@ -0,0 +1,229 @@+-- | Constants describing the DWARF format. Most of this simply+-- mirrors /usr/include/dwarf.h.++module GHC.CmmToAsm.Dwarf.Constants where++import GhcPrelude++import AsmUtils+import FastString+import GHC.Platform+import Outputable++import GHC.Platform.Reg+import GHC.CmmToAsm.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!"
+ compiler/GHC/CmmToAsm/Dwarf/Types.hs view
@@ -0,0 +1,612 @@+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 GhcPrelude++import GHC.Cmm.DebugBlock+import GHC.Cmm.CLabel+import GHC.Cmm.Expr         ( GlobalReg(..) )+import Encoding+import FastString+import Outputable+import GHC.Platform+import Unique+import GHC.Platform.Reg+import SrcLoc+import Util++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 :: 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 (initSDocContext df (mkCodeStyle CStyle)) (ppr label))+  $$ 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 (initSDocContext df (mkCodeStyle CStyle)) (ppr label))+pprDwarfInfoOpen _ (DwarfBlock _ label (Just marker)) = sdocWithDynFlags $ \df ->+  ppr (mkAsmTempDieLabel label) <> colon+  $$ pprAbbrev DwAbbrBlock+  $$ pprString (renderWithStyle (initSDocContext df (mkCodeStyle CStyle)) (ppr label))+  $$ 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 establishes 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
+ compiler/GHC/CmmToAsm/Format.hs view
@@ -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 GhcPrelude++import GHC.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
+ compiler/GHC/CmmToAsm/Instr.hs view
@@ -0,0 +1,202 @@++module GHC.CmmToAsm.Instr (+        RegUsage(..),+        noUsage,+        GenBasicBlock(..), blockId,+        ListGraph(..),+        NatCmm,+        NatCmmDecl,+        NatBasicBlock,+        topInfoTable,+        entryBlocks,+        Instruction(..)+)++where++import GhcPrelude++import GHC.Platform.Reg++import GHC.Cmm.BlockId+import GHC.Cmm.Dataflow.Collections+import GHC.Cmm.Dataflow.Label+import GHC.Driver.Session+import GHC.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+                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+                :: 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]
+ compiler/GHC/CmmToAsm/Monad.hs view
@@ -0,0 +1,294 @@+{-# 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,+        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 GHC.Platform.Reg+import GHC.CmmToAsm.Format+import GHC.CmmToAsm.Reg.Target++import GHC.Cmm.BlockId+import GHC.Cmm.Dataflow.Collections+import GHC.Cmm.Dataflow.Label+import GHC.Cmm.CLabel           ( CLabel )+import GHC.Cmm.DebugBlock+import FastString       ( FastString )+import UniqFM+import UniqSupply+import Unique           ( Unique )+import GHC.Driver.Session+import Module++import Control.Monad    ( ap )++import GHC.CmmToAsm.Instr+import Outputable (SDoc, pprPanic, ppr)+import GHC.Cmm (RawCmmDecl, RawCmmStatics)+import GHC.CmmToAsm.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 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 Debug+    -- 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; <block_l1>`+    -- 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 "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+        = 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)
+ compiler/GHC/CmmToAsm/PIC.hs view
@@ -0,0 +1,837 @@+{-+  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 GhcPrelude++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.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 BasicTypes+import Module++import Outputable++import GHC.Driver.Session+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 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 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 similar 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+--+-- 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++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 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"+
+ compiler/GHC/CmmToAsm/PPC/CodeGen.hs view
@@ -0,0 +1,2455 @@+{-# 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 GhcPrelude++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.CmmToAsm.Monad+   ( NatM, getNewRegNat, getNewLabelNat+   , getBlockIdNat, getPicBaseNat, getNewRegPairNat+   , getPicBaseMaybeNat+   )+import GHC.CmmToAsm.Instr+import GHC.CmmToAsm.PIC+import GHC.CmmToAsm.Format+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++-- The rest:+import OrdList+import Outputable+import GHC.Driver.Session++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 RawCmmStatics 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 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+  -- 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 architectures, 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 ('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' _ (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)+                  (RawCmmStatics 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) (RawCmmStatics 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<b) goto again2+                                   , CMPL fmt rhat (RIReg b)+                                   , BCC LTT again2 Nothing+                                   , BCC ALWAYS endif2 Nothing++                                   , NEWBLOCK endif2+                                     -- compute remainder+                                     -- r = (un21*b + un0 - q0*v) >> 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 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 = 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_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 :: 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 RawCmmStatics 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) (RawCmmStatics 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) $ RawCmmStatics 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
+ compiler/GHC/CmmToAsm/PPC/Cond.hs view
@@ -0,0 +1,63 @@+module GHC.CmmToAsm.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
+ compiler/GHC/CmmToAsm/PPC/Instr.hs view
@@ -0,0 +1,713 @@+{-# 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 GhcPrelude++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.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.Driver.Session+import GHC.Cmm+import GHC.Cmm.Info+import FastString+import GHC.Cmm.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 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++    -- 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+   :: 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 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
+ compiler/GHC/CmmToAsm/PPC/Ppr.hs view
@@ -0,0 +1,994 @@+-----------------------------------------------------------------------------+--+-- Pretty-printing assembly language+--+-- (c) The University of Glasgow 1993-2005+--+-----------------------------------------------------------------------------++{-# OPTIONS_GHC -fno-warn-orphans #-}+module GHC.CmmToAsm.PPC.Ppr (pprNatCmmDecl) where++import GhcPrelude++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.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 Unique                ( pprUniqueAlways, getUnique )+import GHC.Platform+import FastString+import Outputable+import GHC.Driver.Session++import Data.Word+import Data.Int+import Data.Bits++-- -----------------------------------------------------------------------------+-- Printing this stuff out++pprNatCmmDecl :: NatCmmDecl RawCmmStatics 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 (RawCmmStatics 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 RawCmmStatics -> 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 (RawCmmStatics info_lbl info) ->+           pprAlignForSection Text $$+           vcat (map pprData info) $$+           pprLabel info_lbl++++pprDatas :: RawCmmStatics -> SDoc+-- See note [emit-time elimination of static indirections] in CLabel.+pprDatas (RawCmmStatics 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 (RawCmmStatics 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.+            -- 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+    ]++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
+ compiler/GHC/CmmToAsm/PPC/RegInfo.hs view
@@ -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 GhcPrelude++import GHC.CmmToAsm.PPC.Instr++import GHC.Cmm.BlockId+import GHC.Cmm+import GHC.Cmm.CLabel++import Unique+import Outputable (ppr, text, Outputable, (<>))++data JumpDest = DestBlockId BlockId++-- Debug Instance+instance Outputable JumpDest where+  ppr (DestBlockId bid) = text "jd<blk>:" <> 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 (RawCmmStatics lbl statics)+  = RawCmmStatics 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
+ compiler/GHC/CmmToAsm/PPC/Regs.hs view
@@ -0,0 +1,333 @@+{-# 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,++        -- machine specific+        allFPArgRegs,+        fits16Bits,+        makeImmediate,+        fReg,+        r0, sp, toc, r3, r4, r11, r12, r30,+        tmpReg,+        f1,++        allocatableRegs++)++where++#include "HsVersions.h"++import GhcPrelude++import GHC.Platform.Reg+import GHC.Platform.Reg.Class+import GHC.CmmToAsm.Format++import GHC.Cmm+import GHC.Cmm.CLabel           ( CLabel )+import Unique++import GHC.Platform.Regs+import GHC.Driver.Session+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"
+ compiler/GHC/CmmToAsm/Ppr.hs view
@@ -0,0 +1,275 @@+{-# LANGUAGE MagicHash #-}++-----------------------------------------------------------------------------+--+-- Pretty-printing assembly language+--+-- (c) The University of Glasgow 1993-2005+--+-----------------------------------------------------------------------------++module GHC.CmmToAsm.Ppr (+        castFloatToWord8Array,+        castDoubleToWord8Array,+        floatToBytes,+        doubleToBytes,+        pprASCII,+        pprBytes,+        pprSectionHeader+)++where++import GhcPrelude++import AsmUtils+import GHC.Cmm.CLabel+import GHC.Cmm+import GHC.Driver.Session+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"
+ compiler/GHC/CmmToAsm/Reg/Graph.hs view
@@ -0,0 +1,472 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- | Graph coloring register allocator.+module GHC.CmmToAsm.Reg.Graph (+        regAlloc+) where+import GhcPrelude++import qualified GraphColor 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.Platform.Reg.Class+import GHC.Platform.Reg++import Bag+import GHC.Driver.Session+import Outputable+import GHC.Platform+import UniqFM+import UniqSet+import UniqSupply+import Util (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)+        => 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 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)+        => 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++#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
+ compiler/GHC/CmmToAsm/Reg/Graph/Base.hs view
@@ -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 GhcPrelude++import UniqSet+import UniqFM+import Unique+import MonadUtils (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]
+ compiler/GHC/CmmToAsm/Reg/Graph/Coalesce.hs view
@@ -0,0 +1,99 @@+-- | Register coalescing.+module GHC.CmmToAsm.Reg.Graph.Coalesce (+        regCoalesce,+        slurpJoinMovs+) where+import GhcPrelude++import GHC.CmmToAsm.Reg.Liveness+import GHC.CmmToAsm.Instr+import GHC.Platform.Reg++import GHC.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+
+ compiler/GHC/CmmToAsm/Reg/Graph/Spill.hs view
@@ -0,0 +1,382 @@++-- | 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 GhcPrelude++import GHC.CmmToAsm.Reg.Liveness+import GHC.CmmToAsm.Instr+import GHC.Platform.Reg+import GHC.Cmm hiding (RegSet)+import GHC.Cmm.BlockId+import GHC.Cmm.Dataflow.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 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, 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))
+ compiler/GHC/CmmToAsm/Reg/Graph/SpillClean.hs view
@@ -0,0 +1,616 @@+{-# LANGUAGE CPP #-}++-- | 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 GhcPrelude++import GHC.CmmToAsm.Reg.Liveness+import GHC.CmmToAsm.Instr+import GHC.Platform.Reg++import GHC.Cmm.BlockId+import GHC.Cmm+import UniqSet+import UniqFM+import Unique+import State+import 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 [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 (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
+ compiler/GHC/CmmToAsm/Reg/Graph/SpillCost.hs view
@@ -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 GhcPrelude++import GHC.CmmToAsm.Reg.Liveness+import GHC.CmmToAsm.Instr+import GHC.Platform.Reg.Class+import GHC.Platform.Reg++import GraphBase++import GHC.Cmm.Dataflow.Collections (mapLookup)+import GHC.Cmm.Dataflow.Label+import GHC.Cmm+import UniqFM+import UniqSet+import Digraph          (flattenSCCs)+import Outputable+import GHC.Platform+import 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 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 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) ]+
+ compiler/GHC/CmmToAsm/Reg/Graph/Stats.hs view
@@ -0,0 +1,346 @@+{-# 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 GhcPrelude++import qualified GraphColor 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 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)+
+ compiler/GHC/CmmToAsm/Reg/Graph/TrivColorable.hs view
@@ -0,0 +1,274 @@+{-# LANGUAGE CPP #-}++module GHC.CmmToAsm.Reg.Graph.TrivColorable (+        trivColorable,+)++where++#include "HsVersions.h"++import GhcPrelude++import GHC.Platform.Reg.Class+import GHC.Platform.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 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"+                            ArchARM64     -> panic "trivColorable ArchARM64"+                            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"+                            ArchARM64     -> panic "trivColorable ArchARM64"+                            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"+                            ArchARM64     -> panic "trivColorable ArchARM64"+                            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+-}
+ compiler/GHC/CmmToAsm/Reg/Graph/X86.hs view
@@ -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 GhcPrelude++import GHC.CmmToAsm.Reg.Graph.Base  (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)+
+ compiler/GHC/CmmToAsm/Reg/Linear.hs view
@@ -0,0 +1,920 @@+{-# LANGUAGE BangPatterns, CPP, ScopedTypeVariables #-}++{-# 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 GhcPrelude++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.Instr+import GHC.Platform.Reg++import GHC.Cmm.BlockId+import GHC.Cmm.Dataflow.Collections+import GHC.Cmm hiding (RegSet)++import Digraph+import GHC.Driver.Session+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"+      ArchARM64      -> panic "linearRegAlloc ArchARM64"+      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 GHC.Cmm.Pipeline 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+
+ compiler/GHC/CmmToAsm/Reg/Linear/Base.hs view
@@ -0,0 +1,141 @@++-- | Put common type definitions here to break recursive module dependencies.++module GHC.CmmToAsm.Reg.Linear.Base (+        BlockAssignment,++        Loc(..),+        regsOfLoc,++        -- for stats+        SpillReason(..),+        RegAllocStats(..),++        -- the allocator monad+        RA_State(..),+)++where++import GhcPrelude++import GHC.CmmToAsm.Reg.Linear.StackMap+import GHC.CmmToAsm.Reg.Liveness+import GHC.Platform.Reg++import GHC.Driver.Session+import Outputable+import Unique+import UniqFM+import UniqSupply+import GHC.Cmm.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)] }++
+ compiler/GHC/CmmToAsm/Reg/Linear/FreeRegs.hs view
@@ -0,0 +1,89 @@+{-# LANGUAGE CPP #-}++module GHC.CmmToAsm.Reg.Linear.FreeRegs (+    FR(..),+    maxSpillSlots+)++#include "HsVersions.h"++where++import GhcPrelude++import GHC.Platform.Reg+import GHC.Platform.Reg.Class++import GHC.Driver.Session+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 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 :: 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"+                ArchARM64     -> panic "maxSpillSlots ArchARM64"+                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"+
+ compiler/GHC/CmmToAsm/Reg/Linear/JoinToTargets.hs view
@@ -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 GhcPrelude++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.Platform.Reg++import GHC.Cmm.BlockId+import GHC.Cmm.Dataflow.Collections+import Digraph+import GHC.Driver.Session+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.")+
+ compiler/GHC/CmmToAsm/Reg/Linear/PPC.hs view
@@ -0,0 +1,60 @@+-- | Free regs map for PowerPC+module GHC.CmmToAsm.Reg.Linear.PPC where++import GhcPrelude++import GHC.CmmToAsm.PPC.Regs+import GHC.Platform.Reg.Class+import GHC.Platform.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"
+ compiler/GHC/CmmToAsm/Reg/Linear/SPARC.hs view
@@ -0,0 +1,188 @@+{-# LANGUAGE CPP #-}++-- | Free regs map for SPARC+module GHC.CmmToAsm.Reg.Linear.SPARC where++import GhcPrelude++import GHC.CmmToAsm.SPARC.Regs+import GHC.Platform.Reg.Class+import GHC.Platform.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+#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"
+ compiler/GHC/CmmToAsm/Reg/Linear/StackMap.hs view
@@ -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 GhcPrelude++import GHC.Driver.Session+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+
+ compiler/GHC/CmmToAsm/Reg/Linear/State.hs view
@@ -0,0 +1,184 @@+{-# 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 GHC.CmmToAsm.Reg.Linear.State (+        RA_State(..),+        RegM,+        runR,++        spillR,+        loadR,++        getFreeRegsR,+        setFreeRegsR,++        getAssigR,+        setAssigR,++        getBlockAssigR,+        setBlockAssigR,++        setDeltaR,+        getDeltaR,++        getUniqueR,++        recordSpill,+        recordFixupBlock+)+where++import GhcPrelude++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.Platform.Reg+import GHC.Cmm.BlockId++import GHC.Driver.Session+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 }) ()
+ compiler/GHC/CmmToAsm/Reg/Linear/Stats.hs view
@@ -0,0 +1,87 @@+module GHC.CmmToAsm.Reg.Linear.Stats (+        binSpillReasons,+        countRegRegMovesNat,+        pprStats+)++where++import GhcPrelude++import GHC.CmmToAsm.Reg.Linear.Base+import GHC.CmmToAsm.Reg.Liveness+import GHC.CmmToAsm.Instr++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 "")+
+ compiler/GHC/CmmToAsm/Reg/Linear/X86.hs view
@@ -0,0 +1,52 @@++-- | Free regs map for i386+module GHC.CmmToAsm.Reg.Linear.X86 where++import GhcPrelude++import GHC.CmmToAsm.X86.Regs+import GHC.Platform.Reg.Class+import GHC.Platform.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"+
+ compiler/GHC/CmmToAsm/Reg/Linear/X86_64.hs view
@@ -0,0 +1,53 @@++-- | Free regs map for x86_64+module GHC.CmmToAsm.Reg.Linear.X86_64 where++import GhcPrelude++import GHC.CmmToAsm.X86.Regs+import GHC.Platform.Reg.Class+import GHC.Platform.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"++
+ compiler/GHC/CmmToAsm/Reg/Liveness.hs view
@@ -0,0 +1,1025 @@+{-# 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 GhcPrelude++import GHC.Platform.Reg+import GHC.CmmToAsm.Instr++import GHC.Cmm.BlockId+import GHC.CmmToAsm.CFG+import GHC.Cmm.Dataflow.Collections+import GHC.Cmm.Dataflow.Label+import GHC.Cmm hiding (RegSet, emptyRegSet)++import Digraph+import GHC.Driver.Session+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 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 [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 = 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]
+ compiler/GHC/CmmToAsm/Reg/Target.hs view
@@ -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 GhcPrelude++import GHC.Platform.Reg+import GHC.Platform.Reg.Class+import GHC.CmmToAsm.Format++import Outputable+import 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"+      ArchARM64     -> panic "targetVirtualRegSqueeze ArchARM64"+      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"+      ArchARM64     -> panic "targetRealRegSqueeze ArchARM64"+      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"+      ArchARM64     -> panic "targetClassOfRealReg ArchARM64"+      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"+      ArchARM64     -> panic "targetMkVirtualReg ArchARM64"+      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"+      ArchARM64     -> panic "targetRegDotColor ArchARM64"+      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
+ compiler/GHC/CmmToAsm/SPARC/AddrMode.hs view
@@ -0,0 +1,44 @@++module GHC.CmmToAsm.SPARC.AddrMode (+        AddrMode(..),+        addrOffset+)++where++import GhcPrelude++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
+ compiler/GHC/CmmToAsm/SPARC/Base.hs view
@@ -0,0 +1,77 @@++-- | 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 GHC.CmmToAsm.SPARC.Base (+        wordLength,+        wordLengthInBits,+        spillAreaLength,+        spillSlotSize,+        extraStackArgsHere,+        fits13Bits,+        is32BitInteger,+        largeOffsetError+)++where++import GhcPrelude++import GHC.Driver.Session+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")++
+ compiler/GHC/CmmToAsm/SPARC/CodeGen.hs view
@@ -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 GhcPrelude++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 )++-- 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 BasicTypes+import GHC.Driver.Session+import FastString+import OrdList+import 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+  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 RawCmmStatics Instr)+generateJumpTableForInstr dflags (JMP_TBL _ ids label) =+  let jumpTable = map (jumpTableEntry dflags) ids+  in Just (CmmData (Section ReadOnlyData label) (RawCmmStatics 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_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")+
+ compiler/GHC/CmmToAsm/SPARC/CodeGen/Amode.hs view
@@ -0,0 +1,74 @@+module GHC.CmmToAsm.SPARC.CodeGen.Amode (+        getAmode+)++where++import GhcPrelude++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 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)
+ compiler/GHC/CmmToAsm/SPARC/CodeGen/Base.hs view
@@ -0,0 +1,119 @@+module GHC.CmmToAsm.SPARC.CodeGen.Base (+        InstrBlock,+        CondCode(..),+        ChildCode64(..),+        Amode(..),++        Register(..),+        setFormatOfRegister,++        getRegisterReg,+        mangleIndexTree+)++where++import GhcPrelude++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.Driver.Session+import GHC.Cmm+import GHC.Cmm.Ppr.Expr () -- 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"
+ compiler/GHC/CmmToAsm/SPARC/CodeGen/CondCode.hs view
@@ -0,0 +1,110 @@+module GHC.CmmToAsm.SPARC.CodeGen.CondCode (+        getCondCode,+        condIntCode,+        condFltCode+)++where++import GhcPrelude++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 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)
+ compiler/GHC/CmmToAsm/SPARC/CodeGen/Expand.hs view
@@ -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 GhcPrelude++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 Outputable+import 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)
+ compiler/GHC/CmmToAsm/SPARC/CodeGen/Gen32.hs view
@@ -0,0 +1,692 @@+-- | Evaluation of 32 bit values.+module GHC.CmmToAsm.SPARC.CodeGen.Gen32 (+        getSomeReg,+        getRegister+)++where++import GhcPrelude++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.Driver.Session+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) $ RawCmmStatics 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) $ RawCmmStatics 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)
+ compiler/GHC/CmmToAsm/SPARC/CodeGen/Gen32.hs-boot view
@@ -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
+ compiler/GHC/CmmToAsm/SPARC/CodeGen/Gen64.hs view
@@ -0,0 +1,216 @@+-- | Evaluation of 64 bit values on 32 bit platforms.+module GHC.CmmToAsm.SPARC.CodeGen.Gen64 (+        assignMem_I64Code,+        assignReg_I64Code,+        iselExpr64+)++where++import GhcPrelude++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.Driver.Session+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)
+ compiler/GHC/CmmToAsm/SPARC/CodeGen/Sanity.hs view
@@ -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 GhcPrelude++import GHC.CmmToAsm.SPARC.Instr+import GHC.CmmToAsm.SPARC.Ppr        () -- For Outputable instances+import GHC.CmmToAsm.Instr++import GHC.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
+ compiler/GHC/CmmToAsm/SPARC/Cond.hs view
@@ -0,0 +1,54 @@+module GHC.CmmToAsm.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
+ compiler/GHC/CmmToAsm/SPARC/Imm.hs view
@@ -0,0 +1,67 @@+module GHC.CmmToAsm.SPARC.Imm (+        -- immediate values+        Imm(..),+        strImmLit,+        litToImm+)++where++import GhcPrelude++import GHC.Cmm+import GHC.Cmm.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"
+ compiler/GHC/CmmToAsm/SPARC/Instr.hs view
@@ -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 GhcPrelude++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.Cmm.CLabel+import GHC.Platform.Regs+import GHC.Cmm.BlockId+import GHC.Driver.Session+import GHC.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 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+    :: 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.
+ compiler/GHC/CmmToAsm/SPARC/Ppr.hs view
@@ -0,0 +1,645 @@+{-# 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 GhcPrelude++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.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 Unique           ( pprUniqueAlways )+import Outputable+import GHC.Platform+import FastString++-- -----------------------------------------------------------------------------+-- Printing this stuff out++pprNatCmmDecl :: NatCmmDecl RawCmmStatics 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 (RawCmmStatics 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 RawCmmStatics -> 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 (RawCmmStatics info_lbl info) ->+           pprAlignForSection Text $$+           vcat (map pprData info) $$+           pprLabel info_lbl+++pprDatas :: RawCmmStatics -> SDoc+-- See note [emit-time elimination of static indirections] in CLabel.+pprDatas (RawCmmStatics 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 (RawCmmStatics 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"
+ compiler/GHC/CmmToAsm/SPARC/Regs.hs view
@@ -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 GhcPrelude++import GHC.Platform.SPARC+import GHC.Platform.Reg+import GHC.Platform.Reg.Class+import GHC.CmmToAsm.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"
+ compiler/GHC/CmmToAsm/SPARC/ShortcutJump.hs view
@@ -0,0 +1,74 @@+module GHC.CmmToAsm.SPARC.ShortcutJump (+        JumpDest(..), getJumpDestBlockId,+        canShortcut,+        shortcutJump,+        shortcutStatics,+        shortBlockId+)++where++import GhcPrelude++import GHC.CmmToAsm.SPARC.Instr+import GHC.CmmToAsm.SPARC.Imm++import GHC.Cmm.CLabel+import GHC.Cmm.BlockId+import GHC.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) -> RawCmmStatics -> RawCmmStatics+shortcutStatics fn (RawCmmStatics lbl statics)+  = RawCmmStatics 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"
+ compiler/GHC/CmmToAsm/SPARC/Stack.hs view
@@ -0,0 +1,59 @@+module GHC.CmmToAsm.SPARC.Stack (+        spRel,+        fpRel,+        spillSlotToOffset,+        maxSpillSlots+)++where++import GhcPrelude++import GHC.CmmToAsm.SPARC.AddrMode+import GHC.CmmToAsm.SPARC.Regs+import GHC.CmmToAsm.SPARC.Base+import GHC.CmmToAsm.SPARC.Imm++import GHC.Driver.Session+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
+ compiler/GHC/CmmToAsm/X86/CodeGen.hs view
@@ -0,0 +1,3747 @@+{-# 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 GhcPrelude++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+   )+import GHC.CmmToAsm.CFG+import GHC.CmmToAsm.Format+import GHC.Platform.Reg+import GHC.Platform++-- Our intermediate code:+import BasicTypes+import GHC.Cmm.BlockId+import Module           ( 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 SrcLoc           ( srcSpanFile, srcSpanStartLine, srcSpanStartCol )++-- The rest:+import ForeignCall      ( CCallConv(..) )+import OrdList+import Outputable+import FastString+import GHC.Driver.Session+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, RawCmmStatics) 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, 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+  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.+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 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 -> 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).+    -}+    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 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+  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, RawCmmStatics 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.+-}+++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+genCondBranch' is32Bit _bid true false (CmmMachOp mop [e1,e2])+  | is32Bit, Just W64 <- maybeIntComparison mop = do+  ChildCode64 code1 r1_lo <- iselExpr64 e1+  ChildCode64 code2 r2_lo <- iselExpr64 e2+  let r1_hi = getHiVRegFromLo r1_lo+      r2_hi = getHiVRegFromLo r2_lo+      cond = machOpToCond mop+      Just cond' = maybeFlipCond cond+  --TODO: Update CFG for x86+  let code = code1 `appOL` code2 `appOL` toOL [+        CMP II32 (OpReg r2_hi) (OpReg r1_hi),+        JXX cond true,+        JXX cond' false,+        CMP II32 (OpReg r2_lo) (OpReg r1_lo),+        JXX cond true] `appOL` genBranch false+  return code++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:+        <instrs>+    _B1:+        ...+        cmpxchgq ...+        jne _B1+        <instrs>+        <end _B1>+    _B2:+        ...+        cmpxchgq ...+        jne _B2+        <instrs>+        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:+        <instrs>+    _B1:+        ...+        cmpxchgq ...+        jne _B1+        jmp _B1'+    _B1':+        <instrs>+        <end _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)+            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)+            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)+            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)+    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)+    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"+    (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"++    _ -> if is32Bit+         then genCCall32' dflags target dest_regs args+         else genCCall64' dflags target dest_regs args++  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 [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)++      -- 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_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")++-- -----------------------------------------------------------------------------+-- 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.<function we're in> 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, RawCmmStatics) 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, RawCmmStatics) 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, RawCmmStatics 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 <II32++--------------------------------------------------------------------------------+coerceFP2Int :: Width -> 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 <II32+++--------------------------------------------------------------------------------+coerceFP2FP :: Width -> 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 [] = []
+ compiler/GHC/CmmToAsm/X86/Cond.hs view
@@ -0,0 +1,109 @@+module GHC.CmmToAsm.X86.Cond (+        Cond(..),+        condUnsigned,+        condToSigned,+        condToUnsigned,+        maybeFlipCond,+        maybeInvertCond+)++where++import GhcPrelude++data Cond+        = ALWAYS        -- What's really used? ToDo+        | EQQ+        | GE+        | GEU+        | GTT+        | GU+        | LE+        | LEU+        | LTT+        | LU+        | NE+        | NEG+        | POS+        | CARRY+        | OFLO+        | PARITY+        | NOTPARITY+        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
+ compiler/GHC/CmmToAsm/X86/Instr.hs view
@@ -0,0 +1,1056 @@+{-# 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 GhcPrelude++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.Cmm.BlockId+import GHC.Cmm.Dataflow.Collections+import GHC.Cmm.Dataflow.Label+import GHC.Platform.Regs+import GHC.Cmm+import FastString+import Outputable+import GHC.Platform++import BasicTypes       (Alignment)+import GHC.Cmm.CLabel+import GHC.Driver.Session+import UniqSet+import Unique+import UniqSupply+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+        | 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 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:+--+--    <info table>+--    L:+--       <code>+--+-- becomes+--+--    <info table>+--    L:+--       subl $rsp, N+--       jmp Lnew+--    Lnew:+--       <code>+--+-- 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<blk>:" <> ppr bid+  ppr (DestImm _imm)    = text "jd<imm>: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, RawCmmStatics lbl statics)+  = (align, RawCmmStatics 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
+ compiler/GHC/CmmToAsm/X86/Ppr.hs view
@@ -0,0 +1,1014 @@+{-# 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 GhcPrelude++import GHC.CmmToAsm.X86.Regs+import GHC.CmmToAsm.X86.Instr+import GHC.CmmToAsm.X86.Cond+import GHC.CmmToAsm.Instr+import GHC.CmmToAsm.Format+import GHC.Platform.Reg+import GHC.CmmToAsm.Ppr+++import GHC.Cmm.Dataflow.Collections+import GHC.Cmm.Dataflow.Label+import BasicTypes       (Alignment, mkAlignment, alignmentBytes)+import GHC.Driver.Session+import GHC.Cmm              hiding (topInfoTable)+import GHC.Cmm.BlockId+import GHC.Cmm.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+-- <https://developer.apple.com/library/mac/documentation/DeveloperTools/Reference/Assembler/040-Assembler_Directives/asm_directives.html#//apple_ref/doc/uid/TP30000823-TPXREF101>++pprProcAlignment :: SDoc+pprProcAlignment = sdocWithDynFlags $ \dflags ->+  (maybe empty (pprAlign . mkAlignment) (cmmProcAlignment dflags))++pprNatCmmDecl :: NatCmmDecl (Alignment, RawCmmStatics) 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 (RawCmmStatics 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 RawCmmStatics -> NatBasicBlock Instr -> SDoc+pprBasicBlock info_env (BasicBlock blockid instrs)+  = maybe_infotable $+    pprLabel asmLbl $$+    vcat (map pprInstr instrs) $$+    (sdocOption sdocDebugLevel $ \level ->+        if level > 0+           then ppr (mkAsmTempEndLabel asmLbl) <> char ':'+           else empty+    )+  where+    asmLbl = blockLbl blockid+    maybe_infotable c = case mapLookup blockid info_env of+       Nothing -> c+       Just (RawCmmStatics infoLbl info) ->+           pprAlignForSection Text $$+           infoTableLoc $$+           vcat (map pprData info) $$+           pprLabel infoLbl $$+           c $$+           (sdocOption sdocDebugLevel $ \level ->+               if level > 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, RawCmmStatics) -> SDoc+-- See note [emit-time elimination of static indirections] in CLabel.+pprDatas (_, RawCmmStatics 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, (RawCmmStatics 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:+    ```+      <info table data>+    label_info:+      <info table code>+    ```+    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]
+ compiler/GHC/CmmToAsm/X86/RegInfo.hs view
@@ -0,0 +1,73 @@+{-# LANGUAGE CPP #-}+module GHC.CmmToAsm.X86.RegInfo (+        mkVirtualReg,+        regDotColor+)++where++#include "HsVersions.h"++import GhcPrelude++import GHC.CmmToAsm.Format+import GHC.Platform.Reg++import Outputable+import GHC.Platform+import Unique++import UniqFM+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 [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"]++
+ compiler/GHC/CmmToAsm/X86/Regs.hs view
@@ -0,0 +1,442 @@+{-# 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 GhcPrelude++import GHC.Platform.Regs+import GHC.Platform.Reg+import GHC.Platform.Reg.Class++import GHC.Cmm+import GHC.Cmm.CLabel           ( CLabel )+import GHC.Driver.Session+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)+
compiler/GHC/CmmToC.hs view
@@ -39,8 +39,8 @@ import GHC.Cmm.Switch  -- Utils-import CPrim-import DynFlags+import GHC.CmmToAsm.CPrim+import GHC.Driver.Session import FastString import Outputable import GHC.Platform@@ -55,7 +55,7 @@ import Control.Monad.ST import Data.Bits import Data.Char-import Data.List+import Data.List (intersperse) import Data.Map (Map) import Data.Word import System.IO@@ -87,7 +87,7 @@      (case mapLookup (g_entry graph) infos of        Nothing -> empty-       Just (Statics info_clbl info_dat) ->+       Just (RawCmmStatics info_clbl info_dat) ->            pprDataExterns info_dat $$            pprWordArray info_is_in_rodata info_clbl info_dat) $$     (vcat [@@ -110,21 +110,21 @@  -- We only handle (a) arrays of word-sized things and (b) strings. -pprTop (CmmData section (Statics lbl [CmmString str])) =+pprTop (CmmData section (RawCmmStatics 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])) =+pprTop (CmmData section (RawCmmStatics 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)) =+pprTop (CmmData section (RawCmmStatics lbl lits)) =   pprDataExterns lits $$   pprWordArray (isSecConstant section) lbl lits
+ compiler/GHC/CmmToLlvm.hs view
@@ -0,0 +1,222 @@+{-# 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 GhcPrelude++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 BufWrite+import GHC.Driver.Session+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 supportedLlvmVersion) <> " 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)++       -- run code generation+       a <- runLlvm dflags (fromMaybe supportedLlvmVersion mb_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 (RawCmmStatics 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++       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"+      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 ]+  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 <var> 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], [])
+ compiler/GHC/CmmToLlvm/Base.hs view
@@ -0,0 +1,687 @@+{-# 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, supportedLlvmVersion, llvmVersionSupported, parseLlvmVersion,+        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, padLiveArgs, isFPR,++        strCLabel_llvm, strDisplayName_llvm, strProcedureName_llvm,+        getGlobalPtr, generateExternDecls,++        aliasify, llvmDefLabel+    ) where++#include "HsVersions.h"+#include "ghcautoconf.h"++import GhcPrelude++import GHC.Llvm+import GHC.CmmToLlvm.Regs++import GHC.Cmm.CLabel+import GHC.Platform.Regs ( activeStgRegs )+import GHC.Driver.Session+import FastString+import GHC.Cmm              hiding ( succ )+import GHC.Cmm.Utils (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 (sort, groupBy, intercalate)+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 :: 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 platform = targetPlatform dflags+          allRegs = activeStgRegs platform+          paddedLive = map (\(_,r) -> r) $ padLiveArgs dflags live+          isLive r = r `elem` alwaysLive || r `elem` paddedLive+          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++sameFPRClass :: GlobalReg -> GlobalReg -> Bool+sameFPRClass (FloatReg _)  (FloatReg _) = True+sameFPRClass (DoubleReg _) (DoubleReg _) = True+sameFPRClass (XmmReg _)    (XmmReg _) = True+sameFPRClass (YmmReg _)    (YmmReg _) = True+sameFPRClass (ZmmReg _)    (ZmmReg _) = True+sameFPRClass _             _          = False++normalizeFPRNum :: GlobalReg -> GlobalReg+normalizeFPRNum (FloatReg _)  = FloatReg 1+normalizeFPRNum (DoubleReg _) = DoubleReg 1+normalizeFPRNum (XmmReg _)    = XmmReg 1+normalizeFPRNum (YmmReg _)    = YmmReg 1+normalizeFPRNum (ZmmReg _)    = ZmmReg 1+normalizeFPRNum _ = error "normalizeFPRNum expected only FPR regs"++getFPRCtor :: GlobalReg -> Int -> GlobalReg+getFPRCtor (FloatReg _)  = FloatReg+getFPRCtor (DoubleReg _) = DoubleReg+getFPRCtor (XmmReg _)    = XmmReg+getFPRCtor (YmmReg _)    = YmmReg+getFPRCtor (ZmmReg _)    = ZmmReg+getFPRCtor _ = error "getFPRCtor expected only FPR regs"++fprRegNum :: GlobalReg -> Int+fprRegNum (FloatReg i)  = i+fprRegNum (DoubleReg i) = i+fprRegNum (XmmReg i)    = i+fprRegNum (YmmReg i)    = i+fprRegNum (ZmmReg i)    = i+fprRegNum _ = error "fprRegNum expected only FPR regs"++-- | Input: dynflags, and the list of live registers+--+-- Output: An augmented list of live registers, where padding was+-- added to the list of registers to ensure the calling convention is+-- correctly used by LLVM.+--+-- Each global reg in the returned list is tagged with a bool, which+-- indicates whether the global reg was added as padding, or was an original+-- live register.+--+-- That is, True => padding, False => a real, live global register.+--+-- Also, the returned list is not sorted in any particular order.+--+padLiveArgs :: DynFlags -> LiveGlobalRegs -> [(Bool, GlobalReg)]+padLiveArgs dflags live =+      if platformUnregisterised plat+        then taggedLive -- not using GHC's register convention for platform.+        else padding ++ taggedLive+  where+    taggedLive = map (\x -> (False, x)) live+    plat = targetPlatform dflags++    fprLive = filter isFPR live+    padding = concatMap calcPad $ groupBy sharesClass fprLive++    sharesClass :: GlobalReg -> GlobalReg -> Bool+    sharesClass a b = sameFPRClass a b || overlappingClass+      where+        overlappingClass = regsOverlap dflags (norm a) (norm b)+        norm = CmmGlobal . normalizeFPRNum++    calcPad :: [GlobalReg] -> [(Bool, GlobalReg)]+    calcPad rs = getFPRPadding (getFPRCtor $ head rs) rs++getFPRPadding :: (Int -> GlobalReg) -> LiveGlobalRegs -> [(Bool, GlobalReg)]+getFPRPadding paddingCtor live = padding+    where+        fprRegNums = sort $ map fprRegNum live+        (_, padding) = foldl assignSlots (1, []) $ fprRegNums++        assignSlots (i, acc) regNum+            | i == regNum = -- don't need padding here+                  (i+1, acc)+            | i < regNum = let -- add padding for slots i .. regNum-1+                  numNeeded = regNum-i+                  acc' = genPad i numNeeded ++ acc+                in+                  (regNum+1, acc')+            | otherwise = error "padLiveArgs -- i > regNum ??"++        genPad start n =+            take n $ flip map (iterate (+1) start) (\i ->+                (True, paddingCtor i))+++-- | 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 to avoid using the Eq instance!+newtype LlvmVersion = LlvmVersion { llvmVersionNE :: NE.NonEmpty Int }++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 LLVM Version that is currently supported.+supportedLlvmVersion :: LlvmVersion+supportedLlvmVersion = LlvmVersion (sUPPORTED_LLVM_VERSION NE.:| [])++llvmVersionSupported :: LlvmVersion -> Bool+llvmVersionSupported (LlvmVersion v) = NE.head v == sUPPORTED_LLVM_VERSION++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 -> 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+    liftIO $ Outp.bufLeftRenderSDoc dflags out+               (Outp.mkCodeStyle Outp.CStyle) 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+    dflags <- getDynFlags+    mk "memcpy" i8Ptr [i8Ptr, i8Ptr, llvmWord dflags]+    mk "memmove" i8Ptr [i8Ptr, i8Ptr, llvmWord dflags]+    mk "memset" i8Ptr [i8Ptr, llvmWord dflags, llvmWord dflags]+    mk "newSpark" (llvmWord dflags) [i8Ptr, i8Ptr]+  where+    mk n ret args = do+      let n' = llvmDefLabel $ 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)++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 (initSDocContext dflags style) sdoc+    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 (initSDocContext dflags style) 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 -> 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 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@.
+ compiler/GHC/CmmToLlvm/CodeGen.hs view
@@ -0,0 +1,1998 @@+{-# LANGUAGE CPP, GADTs #-}+{-# 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 GhcPrelude++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 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 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 <- 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++    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++    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++    -- parameter types+    let arg_type (_, AddrHint) = i8Ptr+        -- cast pointers to i8*. Llvm equivalent of void*+        arg_type (expr, _) = cmmToLlvmType $ cmmExprType dflags expr++    -- 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) ++ "."++    -- extract Cmm call convention, and translate to LLVM call convention+    platform <- lift $ getLlvmPlatform+    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.+    -}++    -- 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 = tysToParams $ map arg_type args_hints+    let funTy = \name -> LMFunction $ LlvmFunctionDecl name ExternallyVisible+                             lmconv retTy FixedArgs argTy (llvmFunAlign dflags)+++    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<width>, but overflowBit is i1, so we need to cast (Cmm expects+    -- both to be i<width>)+    (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+                 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+++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_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++-- | 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_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 = 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)+                    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 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++  dflags <- getDynFlags+  stmtss <- flip mapM 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++    -- the bool indicates whether the register is padding.+    let alwaysNeeded = map (\r -> (False, r)) alwaysLive+        livePadded = alwaysNeeded ++ 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)+    platform <- getDynFlag targetPlatform+    let allRegs = activeStgRegs platform+    loads <- flip mapM allRegs $ \r -> case () of+      _ | (False, r) `elem` livePadded+                             -> loadExpr r   -- if r is not padding, load it+        | not (isFPR r) || (True, r) `elem` livePadded+                             -> 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 :: 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 $ "GHC.CmmToLlvm.CodeGen." ++ s++pprPanic :: 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
+ compiler/GHC/CmmToLlvm/Data.hs view
@@ -0,0 +1,196 @@+{-# LANGUAGE CPP #-}+-- ----------------------------------------------------------------------------+-- | Handle conversion of CmmData to LLVM code.+--++module GHC.CmmToLlvm.Data (+        genLlvmData, genData+    ) where++#include "HsVersions.h"++import GhcPrelude++import GHC.Llvm+import GHC.CmmToLlvm.Base++import GHC.Cmm.BlockId+import GHC.Cmm.CLabel+import GHC.Cmm+import GHC.Driver.Session+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, RawCmmStatics) -> LlvmM LlvmData+-- See note [emit-time elimination of static indirections] in CLabel.+genLlvmData (_, RawCmmStatics 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, RawCmmStatics 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 isSecConstant sec 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!"
+ compiler/GHC/CmmToLlvm/Mangler.hs view
@@ -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 GhcPrelude++import GHC.Driver.Session ( 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
+ compiler/GHC/CmmToLlvm/Ppr.hs view
@@ -0,0 +1,100 @@+{-# LANGUAGE CPP #-}++-- ----------------------------------------------------------------------------+-- | Pretty print helpers for the LLVM Code generator.+--+module GHC.CmmToLlvm.Ppr (+        pprLlvmCmmDecl, pprLlvmData, infoSection+    ) where++#include "HsVersions.h"++import GhcPrelude++import GHC.Llvm+import GHC.CmmToLlvm.Base+import GHC.CmmToLlvm.Data++import GHC.Cmm.CLabel+import GHC.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 (RawCmmStatics 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 (RawCmmStatics _ 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"
+ compiler/GHC/CmmToLlvm/Regs.hs view
@@ -0,0 +1,136 @@+{-# 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 GhcPrelude++import GHC.Llvm++import GHC.Cmm.Expr+import GHC.Driver.Session+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 $ "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 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 "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
+ compiler/GHC/Core/Lint.hs view
@@ -0,0 +1,2821 @@+{-+(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 GHC.Core.Lint (+    lintCoreBindings, lintUnfolding,+    lintPassResult, lintInteractiveExpr, lintExpr,+    lintAnnots, lintTypes,++    -- ** Debug output+    endPass, endPassIO,+    dumpPassResult,+    GHC.Core.Lint.dumpIfSet,+ ) where++#include "HsVersions.h"++import GhcPrelude++import GHC.Core+import GHC.Core.FVs+import GHC.Core.Utils+import GHC.Core.Stats ( 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 GHC.Core.Ppr+import ErrUtils+import Coercion+import SrcLoc+import Type+import GHC.Types.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 GHC.Core.Arity ( typeArity )+import Demand ( splitStrictSig, isBotDiv )++import GHC.Driver.Types+import GHC.Driver.Session+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. 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 Int in <body>+That is, use a type let.   See Note [Type let] in GHC.Core.++However, when linting <body> 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 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.++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 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 dflags 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+           (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 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. 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 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 vars expr+  | isEmptyBag errs = Nothing+  | otherwise       = Just (pprMessageBag errs)+  where+    in_scope = mkInScopeSet vars+    (_warns, errs) = initL dflags defaultLintFlags in_scope $+                     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+    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 [Core type and coercion invariant] in GHC.Core+       ; 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 [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_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 [Core 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) | isBotDiv 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)+      = lintLambda var $ lint_join_lams (n-1) tot enforce expr++    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 ...)@+        lintLambda+        -- 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 <- 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.++************************************************************************+*                                                                      *+\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)+  = 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 { (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 GHC.Core 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+  = 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 -> LintM Type+lintLambda var lintBody =+    addLoc (LambdaBodyOf var) $+    lintBinder LambdaBind var $ \ var' ->+      do { body_ty <- lintBody+         ; return (mkLamType var' body_ty) }+------------------+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 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  :: 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 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 }++-----------------+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+  = 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 GHC.Core++     ; (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 GHC.Core 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 GHC.Core 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 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 -> OutType -> LintM ()+lintAltExpr expr ann_ty+  = do { actual_ty <- lintCoreExpr expr+       ; ensureEqTys actual_ty ann_ty (mkCaseAltMsg expr actual_ty ann_ty) }+         -- See GHC.Core 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 GHC.Core+       ; lintL (isJoinId id || not (lf_check_levity_poly flags) || 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 GHC.Core.Utils.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 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.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 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+           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]+       , 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 :: LintFlags+defaultLintFlags = LF { lf_check_global_ids = False+                      , lf_check_inline_loop_breakers = True+                      , lf_check_static_ptrs = AllowAnywhere+                      , 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 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++-- 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+  = 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 (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 }++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)
+ compiler/GHC/Core/Ppr/TyThing.hs view
@@ -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 GhcPrelude++import Type    ( Type, ArgFlag(..), TyThing(..), mkTyVarBinders, tidyOpenType )+import GHC.Iface.Syntax ( ShowSub(..), ShowHowMuch(..), AltPpr(..)+  , showToHeader, pprIfaceDecl )+import CoAxiom ( coAxiomTyCon )+import GHC.Driver.Types( tyThingParent_maybe )+import GHC.Iface.Utils ( 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 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.Utils.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+  = 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 "--"
+ compiler/GHC/CoreToByteCode.hs view
@@ -0,0 +1,2055 @@+{-# LANGUAGE CPP, MagicHash, RecordWildCards, BangPatterns #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# 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 GhcPrelude++import GHC.ByteCode.Instr+import GHC.ByteCode.Asm+import GHC.ByteCode.Types++import GHC.Runtime.Interpreter+import GHC.Runtime.Interpreter.Types+import GHCi.FFI+import GHCi.RemoteTypes+import BasicTypes+import GHC.Driver.Session+import Outputable+import GHC.Platform+import Name+import MkId+import Id+import Var             ( updateVarType )+import ForeignCall+import GHC.Driver.Types+import GHC.Core.Utils+import GHC.Core+import GHC.Core.Ppr+import Literal+import PrimOp+import GHC.Core.FVs+import Type+import GHC.Types.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 GHC.Runtime.Heap.Layout hiding (WordOff, ByteOff, wordsToBytes)+import GHC.Data.Bitmap+import OrdList+import Maybes+import VarEnv+import PrelNames ( unsafeEqualityProofName )++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 "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 :: 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 $ "GHC.CoreToByteCode.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 -}] (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 (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]+    -> 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+         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 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 (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<n> 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++-- 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 )+    updateVarType (voidPrimTy `mkVisFunTy`) x++{-+   Ticked Expressions+   ------------------++  The idea is that the "breakpoint<n,fvs> 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# <type> 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 "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+        profiling+          | Just (ExternalInterp _) <- hsc_interp hsc_env = 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/restore 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 $ concatMap 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) 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 "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):++            <arg_n>+            ...+            <arg_1>+            Addr# address_of_C_fn+            <placeholder-for-result#> (must be an unboxed type)++         The interpreter then calls the marshall code mentioned+         in the CCALL insn, passing it (& <placeholder-for-result#>),+         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 "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 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 "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 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+     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 <lbl for first data con>+                  JMP L_Exit++        L1:     TESTEQ_I 1 L2+                  PUSH_G <lbl for second data con>+                  JMP L_Exit+        ...etc...+        Ln:     TESTEQ_I n L_fail+                  PUSH_G <lbl for last data con>+                  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+           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 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+       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 "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+        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)+--  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 ty++tickFS :: FastString+tickFS = fsLit "ticked"
compiler/GHC/CoreToStg.hs view
@@ -17,10 +17,10 @@  import GhcPrelude -import CoreSyn-import CoreUtils        ( exprType, findDefault, isJoinBind+import GHC.Core+import GHC.Core.Utils   ( exprType, findDefault, isJoinBind                         , exprIsTickedString_maybe )-import CoreArity        ( manifestArity )+import GHC.Core.Arity   ( manifestArity ) import GHC.Stg.Syntax  import Type@@ -33,8 +33,7 @@ import CostCentre import VarEnv import Module-import Name             ( isExternalName, nameOccName, nameModule_maybe )-import OccName          ( occNameFS )+import Name             ( isExternalName, nameModule_maybe ) import BasicTypes       ( Arity ) import TysWiredIn       ( unboxedUnitDataCon, unitDataConId ) import Literal@@ -42,11 +41,12 @@ import MonadUtils import FastString import Util-import DynFlags+import GHC.Driver.Session import ForeignCall import Demand           ( isUsedOnce ) import PrimOp           ( PrimCall(..), primOpWrapperId ) import SrcLoc           ( mkGeneralSrcSpan )+import PrelNames        ( unsafeEqualityProofName )  import Data.List.NonEmpty (nonEmpty, toList) import Data.Maybe    (fromMaybe)@@ -198,6 +198,26 @@ --                 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 -- --------------------------------------------------------------@@ -251,7 +271,7 @@ coreTopBindToStg _ _ env ccs (NonRec id e)   | Just str <- exprIsTickedString_maybe e   -- top-level string literal-  -- See Note [CoreSyn top-level string literals] in CoreSyn+  -- See Note [Core top-level string literals] in GHC.Core   = let         env' = extendVarEnv env id how_bound         how_bound = LetBound TopLet 0@@ -268,7 +288,6 @@          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@@ -296,34 +315,8 @@          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@@ -384,8 +377,10 @@   -- 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 _) = coreToStgApp coercionTokenId [] []+coreToStgExpr (Var v) = coreToStgApp v [] []+coreToStgExpr (Coercion _)+  -- See Note [Coercion tokens]+  = coreToStgApp coercionTokenId [] []  coreToStgExpr expr@(App _ _)   = coreToStgApp f args ticks@@ -422,7 +417,7 @@  coreToStgExpr (Case scrut _ _ [])   = coreToStgExpr scrut-    -- See Note [Empty case alternatives] in CoreSyn If the case+    -- 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.     --@@ -432,11 +427,23 @@     -- runtime system error function.  -coreToStgExpr (Case scrut bndr _ alts) = do+coreToStgExpr e0@(Case scrut bndr _ alts) = do     alts2 <- extendVarEnvCts [(bndr, LambdaBound)] (mapM vars_alt alts)     scrut2 <- coreToStgExpr scrut-    return (StgCase scrut2 bndr (mkStgAltType bndr alts) alts2)+    let stg = StgCase scrut2 bndr (mkStgAltType bndr alts) alts2+    -- See (U2) in Note [Implementing unsafeCoerce] in base:Unsafe.Coerce+    case scrut2 of+      StgApp id [] | idName id == unsafeEqualityProofName ->+        case alts2 of+          [(_, [_co], rhs)] ->+            return rhs+          _ ->+            pprPanic "coreToStgExpr" $+              text "Unexpected unsafe equality case expression:" $$ ppr e0 $$+              text "STG:" $$ ppr stg+      _ -> return stg   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.@@ -569,7 +576,7 @@     (args', ts) <- coreToStgArgs args     return (args', ts) -coreToStgArgs (Coercion _ : args)  -- Coercion argument; replace with place holder+coreToStgArgs (Coercion _ : args) -- Coercion argument; See Note [Coercion tokens]   = do { (args', ts) <- coreToStgArgs args        ; return (StgVarArg coercionTokenId : args', ts) }
compiler/GHC/CoreToStg/Prep.hs view
@@ -21,17 +21,16 @@  import OccurAnal -import HscTypes+import GHC.Driver.Types import PrelNames import MkId             ( realWorldPrimId )-import CoreUtils-import CoreArity-import CoreFVs+import GHC.Core.Utils+import GHC.Core.Arity+import GHC.Core.FVs import CoreMonad        ( CoreToDo(..) )-import CoreLint         ( endPassIO )-import CoreSyn-import CoreSubst-import MkCore hiding( FloatBind(..) )   -- We use our own FloatBind here+import GHC.Core.Lint    ( endPassIO )+import GHC.Core+import GHC.Core.Make hiding( FloatBind(..) )   -- We use our own FloatBind here import Type import Literal import Coercion@@ -51,16 +50,14 @@ import Maybes import OrdList import ErrUtils-import DynFlags+import GHC.Driver.Session import Util import Outputable-import GHC.Platform import FastString-import Name             ( NamedThing(..), nameSrcSpan )+import Name             ( NamedThing(..), nameSrcSpan, isInternalName ) 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@@ -243,7 +240,7 @@    -- worker. This is useful, especially for heap profiling.    tick_it name      | debugLevel dflags == 0                = id-     | RealSrcSpan span <- nameSrcSpan name  = tick span+     | 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))@@ -266,40 +263,6 @@         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:@@ -418,22 +381,24 @@                                    -- Nothing <=> added bind' to floats instead cpeBind top_lvl env (NonRec bndr rhs)   | not (isJoinId bndr)-  = do { (_, bndr1) <- cpCloneBndr env 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]-       ; if exprIsTrivial rhs1 && isNotTopLevel top_lvl-            then return (extendCorePrepEnvExpr env bndr rhs1, floats, Nothing)-            else do {+       ; let triv_rhs = cpExprIsTrivial rhs1+             env2    | triv_rhs  = extendCorePrepEnvExpr env1 bndr rhs1+                     | otherwise = env1+             floats1 | triv_rhs, isInternalName (idName bndr)+                     = floats+                     | otherwise+                     = addFloat floats new_float -       ; let new_float = mkFloat dmd is_unlifted bndr1 rhs1+             new_float = mkFloat dmd is_unlifted bndr1 rhs1 -       ; return (extendCorePrepEnv env bndr bndr1,-                 addFloat floats new_float,-                 Nothing) }}+       ; 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@@ -503,8 +468,6 @@         ; return (floats4, rhs4) }   where-    platform = targetPlatform (cpe_dynFlags env)-     arity = idArity bndr        -- We must match this arity      ---------------------@@ -520,14 +483,12 @@       | otherwise = dontFloat floats rhs      ----------------------    float_top floats rhs        -- Urhgh!  See Note [CafInfo and floating]-      | mayHaveCafRefs (idCafInfo bndr)-      , allLazyTop floats+    float_top floats rhs+      | allLazyTop floats       = return (floats, rhs) -      -- So the top-level binding is marked NoCafRefs-      | Just (floats', rhs') <- canFloatFromNoCaf platform floats rhs-      = return (floats', rhs')+      | Just floats <- canFloat floats rhs+      = return floats        | otherwise       = dontFloat floats rhs@@ -654,6 +615,18 @@         ; return (emptyFloats, mkLams bndrs' body') }  cpeRhsE env (Case scrut bndr ty alts)+  | isUnsafeEqualityProof scrut+  , [(con, bs, rhs)] <- alts+  = do { (floats1, scrut') <- cpeBody env scrut+       ; (env1, bndr')     <- cpCloneBndr env bndr+       ; (env2, bs')       <- cpCloneBndrs env1 bs+       ; (floats2, rhs')   <- cpeBody env2 rhs+       ; let case_float = FloatCase scrut' bndr' con bs' True+             floats'    = (floats1 `addFloat` case_float)+                          `appendFloats` floats2+       ; return (floats', rhs') }++  | otherwise   = do { (floats, scrut') <- cpeBody env scrut        ; (env', bndr2) <- cpCloneBndr env bndr        ; let alts'@@ -670,6 +643,7 @@                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)@@ -987,7 +961,7 @@                               -> (# State# RealWorld, o #)  It needs no special treatment in GHC except this special inlining here-in CorePrep (and in ByteCodeGen).+in CorePrep (and in GHC.CoreToByteCode).  -- --------------------------------------------------------------------------- --      CpeArg: produces a result satisfying CpeArg@@ -1024,8 +998,29 @@ -- 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)+okCpeArg expr    = not (cpExprIsTrivial expr) +cpExprIsTrivial :: CoreExpr -> Bool+cpExprIsTrivial e+  | Tick t e <- e+  , not (tickishIsCode t)+  = cpExprIsTrivial e+  | Case scrut _ _ alts <- e+  , isUnsafeEqualityProof scrut+  , [(_,_,rhs)] <- alts+  = cpExprIsTrivial rhs+  | otherwise+  = exprIsTrivial e++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+ -- This is where we arrange that a non-trivial argument is let-bound cpeArg :: CorePrepEnv -> Demand        -> CoreArg -> Type -> UniqSM (Floats, CpeArg)@@ -1099,7 +1094,7 @@ {- ************************************************************************ *                                                                      *-                Simple CoreSyn operations+                Simple GHC.Core operations *                                                                      * ************************************************************************ -}@@ -1142,7 +1137,7 @@ 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+Instead GHC.Core.Arity.etaExpand gives                 f = /\a -> \y -> let s = h 3 in g s y  -}@@ -1166,7 +1161,7 @@ -}  -- When updating this function, make sure it lines up with--- CoreUtils.tryEtaReduce!+-- GHC.Core.Utils.tryEtaReduce! tryEtaReducePrep :: [CoreBndr] -> CoreExpr -> Maybe CoreExpr tryEtaReducePrep bndrs expr@(App _ _)   | ok_to_eta_reduce f@@ -1215,8 +1210,11 @@                          -- unlifted ones are done with FloatCase   | FloatCase-      Id CpeBody-      Bool              -- The bool indicates "ok-for-speculation"+      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)@@ -1225,7 +1223,11 @@  instance Outputable FloatingBind where   ppr (FloatLet b) = ppr b-  ppr (FloatCase b r ok) = brackets (ppr ok) <+> ppr b <+> equals <+> ppr r+  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@@ -1248,17 +1250,19 @@  mkFloat :: Demand -> Bool -> Id -> CpeRhs -> FloatingBind mkFloat dmd is_unlifted bndr rhs-  | use_case  = FloatCase bndr rhs (exprOkForSpeculation 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-    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@@ -1270,19 +1274,19 @@ 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+    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+    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@@ -1311,8 +1315,8 @@   = foldrOL get [] floats   where     get (FloatLet b) bs = occurAnalyseRHSs b : bs-    get (FloatCase var body _) bs  =-      occurAnalyseRHSs (NonRec var body) : bs+    get (FloatCase body var _ _ _) bs+      = occurAnalyseRHSs (NonRec var body) : bs     get b _ = pprPanic "corePrepPgm" (ppr b)      -- See Note [Dead code in CorePrep]@@ -1321,58 +1325,28 @@  --------------------------------------------------------------------------- -canFloatFromNoCaf :: Platform -> Floats -> CpeRhs -> Maybe (Floats, CpeRhs)-       -- Note [CafInfo and floating]-canFloatFromNoCaf platform (Floats ok_to_spec fs) rhs+canFloat :: Floats -> CpeRhs -> Maybe (Floats, CpeRhs)+canFloat (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)+  , Just fs' <- go nilOL (fromOL fs)+  = Just (Floats OkToSpec fs', rhs)   | otherwise   = Nothing   where-    subst_expr = substExpr (text "CorePrep")+    go :: OrdList FloatingBind -> [FloatingBind]+       -> Maybe (OrdList FloatingBind) -    go :: (Subst, OrdList FloatingBind) -> [FloatingBind]-       -> Maybe (Subst, OrdList FloatingBind)+    go (fbs_out) [] = Just fbs_out -    go (subst, fbs_out) [] = Just (subst, fbs_out)+    go fbs_out (fb@(FloatLet _) : fbs_in)+      = go (fbs_out `snocOL` fb) fbs_in -    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 fbs_out (ft@FloatTick{} : fbs_in)+      = go (fbs_out `snocOL` ft) fbs_in -    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 _ (FloatCase{} : _) = Nothing -    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@@ -1405,66 +1379,68 @@ --                      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.+{- 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@@ -1588,7 +1564,7 @@         -- Drop (now-useless) rules/unfoldings        -- See Note [Drop unfoldings and rules]-       -- and Note [Preserve evaluatedness] in CoreTidy+       -- and Note [Preserve evaluatedness] in GHC.Core.Op.Tidy        ; let unfolding' = zapUnfolding (realIdUnfolding bndr)                           -- Simplifier will set the Id's unfolding @@ -1621,7 +1597,7 @@     we'd have to substitute in them  HOWEVER, we want to preserve evaluated-ness;-see Note [Preserve evaluatedness] in CoreTidy.+see Note [Preserve evaluatedness] in GHC.Core.Op.Tidy. -}  ------------------------------------------------------------------------------@@ -1693,9 +1669,9 @@         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!"+        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)
compiler/GHC/Data/Bitmap.hs view
@@ -10,16 +10,15 @@  module GHC.Data.Bitmap (         Bitmap, mkBitmap,-        intsToBitmap, intsToReverseBitmap,+        intsToReverseBitmap,         mAX_SMALL_BITMAP_SIZE,-        seqBitmap,   ) where  import GhcPrelude -import GHC.Runtime.Layout-import DynFlags-import Util+import GHC.Platform+import GHC.Runtime.Heap.Layout+import GHC.Driver.Session  import Data.Bits @@ -43,31 +42,6 @@     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).@@ -101,7 +75,7 @@ {-  Note [Strictness when building Bitmaps]-========================================+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~  One of the places where @Bitmap@ is used is in in building Static Reference Tables (SRTs) (in @GHC.Cmm.Info.Build.procpointSRT@). In #7450 it was noticed@@ -125,10 +99,7 @@ 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-+mAX_SMALL_BITMAP_SIZE dflags =+    case platformWordSize (targetPlatform dflags) 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
+ compiler/GHC/Driver/Backpack.hs view
@@ -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 GhcPrelude++-- In a separate module because it hooks into the parser.+import GHC.Driver.Backpack.Syntax++import ApiAnnotation+import GHC hiding (Failed, Succeeded)+import GHC.Driver.Packages+import Parser+import Lexer+import GHC.Driver.Monad+import GHC.Driver.Session+import TcRnMonad+import TcRnDriver+import Module+import GHC.Driver.Types+import StringBuffer+import FastString+import ErrUtils+import SrcLoc+import GHC.Driver.Main+import UniqFM+import UniqDFM+import Outputable+import Maybes+import HeaderInfo+import GHC.Iface.Utils+import GHC.Driver.Make+import UniqDSet+import PrelNames+import BasicTypes hiding (SuccessFlag(..))+import GHC.Driver.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 / 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 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 (getUnitInfoMap 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=<A>]@ in a+-- unit file, return the 'UnitId' corresponding to @p[A=<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 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 (improveUnitId (getUnitInfoMap 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))++-- | Register a new virtual package database containing a single unit+addPackage :: GhcMonad m => UnitInfo -> m ()+addPackage pkg = do+    dflags <- GHC.getSessionDynFlags+    case pkgDatabase dflags of+        Nothing -> panic "addPackage: called too early"+        Just dbs -> do+         let newdb = PackageDatabase+               { packageDatabasePath  = "(in memory " ++ showSDoc dflags (ppr (unitId pkg)) ++ ")"+               , packageDatabaseUnits = [pkg]+               }+         _ <- GHC.setSessionDynFlags (dflags { pkgDatabase = Just (dbs ++ [newdb]) })+         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 lookupUnit 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+                                (initSDocContext dflags (backpackStyle dflags))+                                (ppr pk)++-- | 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 (initSDocContext dflags (backpackStyle dflags))+            (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 :: 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 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 (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 = 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 (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.+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
+ compiler/GHC/Driver/CodeOutput.hs view
@@ -0,0 +1,264 @@+{-+(c) The GRASP/AQUA Project, Glasgow University, 1993-1998++\section{Code output phase}+-}++{-# LANGUAGE CPP #-}++module GHC.Driver.CodeOutput ( codeOutput, outputForeignStubs ) where++#include "HsVersions.h"++import GhcPrelude++import GHC.CmmToAsm     ( nativeCodeGen )+import GHC.CmmToLlvm    ( llvmCodeGen )++import UniqSupply       ( mkSplitUniqSupply )++import GHC.Driver.Finder    ( mkStubPaths )+import GHC.CmmToC           ( writeC )+import GHC.Cmm.Lint         ( cmmLint )+import GHC.Driver.Packages+import GHC.Cmm              ( RawCmmGroup )+import GHC.Driver.Types+import GHC.Driver.Session+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"+                      FormatC+                      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 <ffi.h>\n"+              | otherwise = ""++        stub_h_file_exists+           <- outputForeignStubs_help stub_h stub_h_output_w+                ("#include <HsFFI.h>\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 <Rts.h>\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
+ compiler/GHC/Driver/Finder.hs view
@@ -0,0 +1,844 @@+{-+(c) The University of Glasgow, 2000-2006++\section[Finder]{Module Finder}+-}++{-# LANGUAGE CPP #-}++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 GhcPrelude++import Module+import GHC.Driver.Types+import GHC.Driver.Packages+import FastString+import Util+import PrelNames        ( gHC_PRIM )+import GHC.Driver.Session+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 '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( installedModuleUnitId mod == installedUnitInfoId pkg_conf, ppr (installedModuleUnitId mod) <+> ppr (installedUnitInfoId 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 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 dflags uid)+           in text "Perhaps you need to add" <+>+              quotes (ppr (packageName pkg)) <+>+              text "to the build-depends in your .cabal file."+     | Just pkg <- lookupUnit dflags uid+         = 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)
+ compiler/GHC/Driver/Main.hs view
@@ -0,0 +1,1949 @@+{-# 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+    , 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 GhcPrelude++import Data.Data hiding (Fixity, TyCon)+import Data.Maybe       ( fromJust )+import Id+import GHC.Runtime.Interpreter ( addSptEntry )+import GHCi.RemoteTypes        ( ForeignHValue )+import GHC.CoreToByteCode      ( byteCodeGen, coreExprToBCOs )+import GHC.Runtime.Linker+import GHC.Core.Op.Tidy        ( tidyExpr )+import Type                    ( Type, Kind )+import GHC.Core.Lint           ( lintInteractiveExpr )+import VarEnv                  ( emptyTidyEnv )+import Panic+import ConLike++import ApiAnnotation+import Module+import GHC.Driver.Packages+import RdrName+import GHC.Hs+import GHC.Hs.Dump+import GHC.Core+import StringBuffer+import Parser+import Lexer+import SrcLoc+import TcRnDriver+import GHC.IfaceToCore  ( typecheckIface )+import TcRnMonad+import TcHsSyn          ( ZonkFlexi (DefaultFlexi) )+import NameCache        ( initNameCache )+import GHC.Iface.Load   ( ifaceStats, initExternalPackageState )+import PrelInfo+import GHC.Iface.Utils+import GHC.HsToCore+import SimplCore+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 CostCentre+import ProfInit+import TyCon+import Name+import NameSet+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 InstEnv+import FamInstEnv+import Fingerprint      ( Fingerprint )+import GHC.Driver.Hooks+import TcEnv+import PrelNames+import GHC.Driver.Plugins+import GHC.Runtime.Loader   ( initializePlugins )++import GHC.Driver.Session+import ErrUtils++import Outputable+import NameEnv+import HscStats         ( ppSourceStats )+import GHC.Driver.Types+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 Data.Functor+import Control.DeepSeq (force)++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)+import GHC.Iface.Ext.Debug  ( 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+    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+    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 "<built-in>" and "<command-line>"+            --   - 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+++-- -----------------------------------------------------------------------------+-- | 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++        -- 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 $+    hsc_typecheck True mod_summary (Just rdr_module)+++-- | A bunch of logic piled around 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' = 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 )+    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?+    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+            (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 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 <- finish mod_summary tc_result mb_old_hash+            return (status, 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+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_mod_details = details,+                             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"+    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+-- 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  -- [UnitId]++    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 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)+                        $ mkErrMsg 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   = 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" #-}+            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)], NameSet)+               -- ^ @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" #-}+                      lookupHook cmmToRawCmmHook+                        (\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, caf_infos)+                <- {-# SCC "codeOutput" #-}+                  codeOutput dflags this_mod output_filename location+                  foreign_stubs foreign_files dependencies rawcmms1+            return (output_filename, stub_c_exists, foreign_fps, caf_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 = mkModule (thisPackage 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 cmmToRawCmmHook+                     (\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 NameSet)+         -- 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 stg_binds_w_fvs)++    let cmm_stream :: Stream IO CmmGroup ()+        -- 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 =+          {-# SCC "cmmPipeline" #-}+          Stream.mapAccumL (cmmPipeline hsc_env) (emptySRT this_mod) ppr_stream1+            <&> (srtMapNonCAFs . moduleSRTMap)++        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 "<interactive>" 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 "<interactive>" 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. 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 "<interactive>" 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 { let dflags = hsc_dflags hsc_env++           {- 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 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
+ compiler/GHC/Driver/Make.hs view
@@ -0,0 +1,2739 @@+{-# 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,++        IsBoot(..),+        summariseModule,+        hscSourceToIsBoot,+        findExtraSigImports,+        implicitRequirements,++        noModError, cyclicModuleErr,+        moduleGraphNodes, SummaryNode+    ) where++#include "HsVersions.h"++import GhcPrelude++import qualified GHC.Runtime.Linker as Linker++import GHC.Driver.Phases+import GHC.Driver.Pipeline+import GHC.Driver.Session+import ErrUtils+import GHC.Driver.Finder+import GHC.Driver.Monad+import HeaderInfo+import GHC.Driver.Types+import Module+import GHC.IfaceToCore  ( typecheckIface )+import TcRnMonad        ( initIfaceCheck )+import GHC.Driver.Main++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 )+import Outputable+import Panic+import SrcLoc+import StringBuffer+import UniqFM+import UniqDSet+import TcBackpack+import GHC.Driver.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.+-- 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+        warnMissingHomeModules hsc_env mod_graph+        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 :: 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.+--+-- 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+    warnUnusedPackages+    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 :: 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 -> UnitInfo -> Bool+        matchingStr str p+                =  str == sourcePackageIdString p+                || str == packageNameString p++        matching :: DynFlags -> PackageArg -> UnitInfo -> 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 -> UnitInfo -> UnitId+        realUnitId dflags+          = unwireUnitId dflags+          . DefiniteUnitId+          . DefUnitId+          . installedUnitInfoId++-- | 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 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, 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 probably 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 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 &&+                                 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))+++-----------------------------------------------------------------------------+--+-- | 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 "<command line>")++        -- 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_ByteCode (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 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+          -> 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)))
+ compiler/GHC/Driver/MakeFile.hs view
@@ -0,0 +1,424 @@+{-# LANGUAGE CPP #-}++-----------------------------------------------------------------------------+--+-- Makefile Dependency Generation+--+-- (c) The University of Glasgow 2005+--+-----------------------------------------------------------------------------++module GHC.Driver.MakeFile+   ( doMkDependHS+   )+where++#include "HsVersions.h"++import GhcPrelude++import qualified GHC+import GHC.Driver.Monad+import GHC.Driver.Session+import Util+import GHC.Driver.Types+import qualified SysTools+import Module+import Digraph          ( SCC(..) )+import GHC.Driver.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 )+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++                -- 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 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"+
+ compiler/GHC/Driver/Pipeline.hs view
@@ -0,0 +1,2342 @@+{-# LANGUAGE CPP, NamedFieldPuns, NondecreasingIndentation, BangPatterns, MultiWayIf #-}++{-# 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 <ghcplatform.h>+#include "HsVersions.h"++import GhcPrelude++import GHC.Driver.Pipeline.Monad+import GHC.Driver.Packages+import HeaderInfo+import GHC.Driver.Phases+import SysTools+import SysTools.ExtraObj+import GHC.Driver.Main+import GHC.Driver.Finder+import GHC.Driver.Types hiding ( Hsc )+import Outputable+import Module+import ErrUtils+import GHC.Driver.Session+import Panic+import Util+import StringBuffer     ( hGetStringBuffer, hPutStringBuffer )+import BasicTypes       ( SuccessFlag(..) )+import Maybes           ( expectJust )+import SrcLoc+import GHC.CmmToLlvm    ( llvmFixupAsm, llvmVersionList )+import MonadUtils+import GHC.Platform+import TcRnTypes+import ToolSettings+import GHC.Driver.Hooks+import qualified GHC.LanguageExtensions as LangExt+import FileCleanup+import Ar+import Bag              ( unitBag )+import FastString       ( mkFastString )+import GHC.Iface.Utils  ( mkFullIface )+import UpdateCafInfos   ( updateModDetailsCafInfos )++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, 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_mod_details = hmi_details,+                     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 Nothing+            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, details)) <- 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 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+#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 (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++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, ModDetails))+                                -- ^ (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, ModDetails))+                                -- ^ (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+       -- 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 $ 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, 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_mod_details = mod_details,+                        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, caf_infos) <- liftIO $+                      hscGenHardCode hsc_env' cgguts mod_location output_fn++                    final_iface <- liftIO (mkFullIface hsc_env'{hsc_dflags=iface_dflags} partial_iface (Just caf_infos))+                    let final_mod_details = {-# SCC updateModDetailsCafInfos #-}+                                            updateModDetailsCafInfos caf_infos mod_details+                    setIface final_iface final_mod_details++                    -- 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 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 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 . 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 [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 gopt Opt_RPath dflags+                          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<some+                  -- dir> 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 &&+           gopt Opt_RPath dflags+            = 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,<sym> contained in other_flags+                 -- needs to be put before -l<package>,+                 -- 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 = if staticLink+                   then SysTools.runLibtool+                   else SysTools.runLink+    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+                               ArchARM64  -> 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+                          then [ "-Wl,-dead_strip_dylibs" ]+                          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 $+             "<?xml version=\"1.0\" encoding=\"UTF-8\" standalone=\"yes\"?>\n"+++             "  <assembly xmlns=\"urn:schemas-microsoft-com:asm.v1\" manifestVersion=\"1.0\">\n"+++             "  <assemblyIdentity version=\"1.0.0.0\"\n"+++             "     processorArchitecture=\"X86\"\n"+++             "     name=\"" ++ dropExtension exe_filename ++ "\"\n"+++             "     type=\"win32\"/>\n\n"+++             "  <trustInfo xmlns=\"urn:schemas-microsoft-com:asm.v3\">\n"+++             "    <security>\n"+++             "      <requestedPrivileges>\n"+++             "        <requestedExecutionLevel level=\"asInvoker\" uiAccess=\"false\"/>\n"+++             "        </requestedPrivileges>\n"+++             "       </security>\n"+++             "  </trustInfo>\n"+++             "</assembly>\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 <- 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 [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 (lookupUnit 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 :: [UnitInfo] -> 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 (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.+-}++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 cc = SysTools.runLink dflags ([+                       SysTools.Option "-nostdlib",+                       SysTools.Option "-Wl,-r"+                     ]+                        -- See Note [No PIE while linking] in DynFlags+                     ++ (if toolSettings_ccSupportsNoPie toolSettings'+                          then [SysTools.Option "-no-pie"]+                          else [])++                     ++ (if any (cc ==) [Clang, AppleClang, AppleClang51]+                          then []+                          else [SysTools.Option "-nodefaultlibs"])+                     ++ (if osInfo == OSFreeBSD+                          then [SysTools.Option "-L/usr/lib"]+                          else [])+                        -- gcc on sparc sets -Wl,--relax implicitly, but+                        -- -r and --relax are incompatible for ld, so+                        -- disable --relax explicitly.+                     ++ (if platformArch (targetPlatform dflags)+                                `elem` [ArchSPARC, ArchSPARC64]+                         && ldIsGnuLd+                            then [SysTools.Option "-Wl,-no-relax"]+                            else [])+                        -- See Note [Produce big objects on Windows]+                     ++ [ SysTools.Option "-Wl,--oformat,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' = ["-Wl,--build-id=none"]+                  | otherwise                     = []++  ccInfo <- getCompilerInfo dflags+  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] ccInfo+     else if toolSettings_ldSupportsFilelist toolSettings'+     then do+          filelist <- newTempName dflags TFL_CurrentModule "filelist"+          writeFile filelist $ unlines o_files+          ld_r [SysTools.Option "-Wl,-filelist",+                SysTools.FileOption "-Wl," filelist] ccInfo+     else do+          ld_r (map (SysTools.FileOption "") o_files) ccInfo++-- -----------------------------------------------------------------------------+-- 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+  `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.+-}
+ compiler/GHC/HsToCore.hs view
@@ -0,0 +1,756 @@+{-+(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 GhcPrelude++import GHC.HsToCore.Usage+import GHC.Driver.Session+import GHC.Driver.Types+import GHC.Hs+import TcRnTypes+import TcRnMonad  ( finalSafeMode, fixSafeInstances )+import TcRnDriver ( runTcInteractive )+import Id+import IdInfo+import Name+import Type+import TyCon       ( tyConDataCons )+import 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 PrelNames+import TysPrim+import Coercion+import TysWiredIn+import DataCon     ( dataConWrapId )+import GHC.Core.Make+import Module+import NameSet+import NameEnv+import GHC.Core.Rules+import BasicTypes+import CoreMonad        ( CoreToDo(..) )+import GHC.Core.Lint    ( endPassIO )+import VarSet+import FastString+import ErrUtils+import Outputable+import SrcLoc+import GHC.HsToCore.Coverage+import Util+import MonadUtils+import 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 (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"+                         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 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 (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)+        } } }+dsRule (L _ (XRuleDecl nec)) = noExtCon nec++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 TysWiredIn and for Ids+in MkId. See Note [Wired-in Ids] in MkId.++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:+--------+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 like any other definition.+At optimization level 0, we enable -fignore-interface-pragmas, which+ignores pragmas in interface files. We thus must check to see whether+there is a compulsory unfolding, even with -fignore-interface-pragmas.+This is done in TcIface.tcIdInfo.++Test case: ghci/linker/dyn/T3372++-}+++-- 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 scrut1_ty)+                                   (DataAlt unsafe_refl_data_con)+                                   [rr_cv] $+                   mkSingleAltCase scrut2+                                   (mkWildValBinder 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 ] $+                  mkVisFunTy openAlphaTy openBetaTy++             id   = mkExportedVanillaId unsafeCoercePrimName ty `setIdInfo` info+       ; return (id, old_expr) }++  where
+ compiler/GHC/HsToCore/Arrows.hs view
@@ -0,0 +1,1270 @@+{-+(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 GhcPrelude++import GHC.HsToCore.Match+import GHC.HsToCore.Utils+import GHC.HsToCore.Monad++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 #-} GHC.HsToCore.Expr ( dsExpr, dsLExpr, dsLExprNoLP, dsLocalBinds,+                                          dsSyntaxExpr )++import TcType+import Type ( splitPiTy )+import TcEvidence+import GHC.Core+import GHC.Core.FVs+import GHC.Core.Utils+import GHC.Core.Make+import GHC.HsToCore.Binds (dsHsWrapper)++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 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 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 (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+          = (L _ [L _ (Match { m_pats  = pats+                             , m_grhss = GRHSs _ [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+       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 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)++-- 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 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 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 [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 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]+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+                        (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 }))+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) (L loc (GRHS x stmts _))+  = (leaves, L 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 (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 (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 _ (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
+ compiler/GHC/HsToCore/Binds.hs view
@@ -0,0 +1,1328 @@+{-+(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 GhcPrelude++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 ( needToRunPmCheck, addTyCsDs, checkGuardMatches )++import GHC.Hs             -- lots of things+import GHC.Core           -- lots of things+import GHC.Core.SimpleOpt ( simpleOptExpr )+import OccurAnal          ( occurAnalyseExpr )+import GHC.Core.Make+import GHC.Core.Utils+import GHC.Core.Arity     ( etaExpand )+import GHC.Core.Unfold+import GHC.Core.FVs+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 GHC.Core.Rules+import VarEnv+import Var( EvVar )+import Outputable+import Module+import SrcLoc+import Maybes+import OrdList+import Bag+import BasicTypes+import GHC.Driver.Session+import FastString+import Util+import UniqSet( nonDetEltsUniqSet )+import MonadUtils+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+                         , 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 = L _ fun+                           , fun_matches = matches+                           , fun_ext = 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  { 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 <- 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 `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 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 GHC.HsToCore.Expr.ds_val_bind.++Consider a recursive group like this++  letrec+     f : g = rhs[f,g]+  in <body>++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 <body>++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 <body>` 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` <body>+++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 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 (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, args) -> do++       { this_mod <- getModule+       ; let fn_unf    = realIdUnfolding poly_id+             spec_unf  = specUnfolding dflags spec_bndrs core_app arity_decrease fn_unf+             spec_id   = mkLocalId spec_name spec_ty+                            `setInlinePragma` inl_prag+                            `setIdUnfolding`  spec_unf+             arity_decrease = count isValArg args - count isId spec_bndrs++       ; rule <- dsMkUserRule this_mod is_local_id+                        (mkFastString ("SPEC " ++ showPpr dflags poly_name))+                        rule_act poly_name+                        rule_bndrs 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)) (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 = <rhs>+        ... 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 = <rhs> 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 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 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)
+ compiler/GHC/HsToCore/Binds.hs-boot view
@@ -0,0 +1,6 @@+module GHC.HsToCore.Binds where+import GHC.HsToCore.Monad ( DsM )+import GHC.Core           ( CoreExpr )+import TcEvidence         (HsWrapper)++dsHsWrapper :: HsWrapper -> DsM (CoreExpr -> CoreExpr)
+ compiler/GHC/HsToCore/Coverage.hs view
@@ -0,0 +1,1368 @@+{-+(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 GhcPrelude as Prelude++import qualified GHC.Runtime.Interpreter as GHCi+import GHCi.RemoteTypes+import Data.Array+import GHC.ByteCode.Types+import GHC.Stack.CCS+import Type+import GHC.Hs+import Module+import Outputable+import GHC.Driver.Session+import ConLike+import Control.Monad+import SrcLoc+import ErrUtils+import NameSet hiding (FreeVars)+import Name+import Bag+import CostCentre+import CostCentreState+import GHC.Core+import Id+import VarSet+import Data.List+import FastString+import GHC.Driver.Types+import TyCon+import BasicTypes+import MonadUtils+import Maybes+import GHC.Cmm.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.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,+    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    = 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, Just 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 ModBreaks+mkModBreaks hsc_env mod count entries+  | HscInterpreted <- hscTarget (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 emptyModBreaks+                       { modBreaks_flags = breakArray+                       , modBreaks_locs  = locsTicks+                       , modBreaks_vars  = varsTicks+                       , modBreaks_decls = declsTicks+                       , modBreaks_ccs   = ccs+                       }+  | otherwise = return emptyModBreaks++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 -- <tab> 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)++  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 $ 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+addTickLHsBind bind@(L _ (XHsBindsLR {})) = return 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 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 (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 (HsWrap w e)) =+        liftM XExpr $+        liftM (HsWrap 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 (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))+addTickTupArg (L _ (XTupArg nec)) = noExtCon nec+++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' }+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 (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+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@(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 (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' }) }++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 (L 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@(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)+addTickHsCmdTop (XCmdTop nec) = noExtCon nec++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 (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' }+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 (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+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 (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"+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 (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+                         }++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 (hscTarget dflags == HscInterpreted) 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++-- | 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 -> 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 (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 =+ 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+     ( L pos $ HsTick noExtField (HpcTick (this_mod env) c)+          $ L 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 (L _ (Match { m_grhss = GRHSs _ grhss _ }))+          = length grhss+        matchCount (L _ (Match { m_grhss = XGRHSs nec }))+          = noExtCon nec+        matchCount (L _ (XMatch nec)) = noExtCon nec++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_<module>()`, 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
+ compiler/GHC/HsToCore/Docs.hs view
@@ -0,0 +1,357 @@+-- | Extract docs from the renamer output so they can be be serialized.+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ViewPatterns #-}++{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}++module GHC.HsToCore.Docs (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.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 l (InstD _ d) = maybeToList $ -- See Note [1].+      case d of+              TyFamInstD _ _ -> M.lookup l instanceMap+                -- The CoAx's loc is the whole line, but only+                -- for TFs+              _ -> 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 :: 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 = 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 = 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 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_fvf = ForallInvis+                      , 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 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 . 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 (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"++-- | 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
+ compiler/GHC/HsToCore/Expr.hs view
@@ -0,0 +1,1205 @@+{-+(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 GhcPrelude++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 ( checkGuardMatches )+import Name+import NameEnv+import 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 TcType+import TcEvidence+import TcRnMonad+import Type+import GHC.Core+import GHC.Core.Utils+import GHC.Core.Make++import GHC.Driver.Session+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+import Data.List.NonEmpty ( nonEmpty )++{-+************************************************************************+*                                                                      *+                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+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 (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+  | [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 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 = 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 upat+       ; 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 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 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 hswrap@(XExpr (HsWrap co_fn e))+  = do { e' <- case e of+                 HsVar _ (L _ var) -> return $ varToCoreExpr var+                 HsConLikeOut _ (RealDataCon dc) -> return $ varToCoreExpr (dataConWrapId dc)+                 XExpr (HsWrap _ _) -> pprPanic "dsExpr: HsWrap inside HsWrap" (ppr hswrap)+                 HsPar _ _ -> pprPanic "dsExpr: HsPar inside HsWrap" (ppr hswrap)+                 _ -> dsExpr e+               -- See Note [Detecting forced eta expansion]+       ; wrap' <- dsHsWrapper co_fn+       ; dflags <- getDynFlags+       ; let wrapped_e = wrap' e'+             wrapped_ty = exprType wrapped_e+       ; checkForcedEtaExpansion e (ppr hswrap) wrapped_ty -- See Note [Detecting forced eta expansion]+         -- Pass HsWrap, so that the user can see entire expression with -fprint-typechecker-elaboration+       ; warnAboutIdentities dflags e' wrapped_ty+       ; return wrapped_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 (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.++Operator sections.  At first it looks as if we can convert+\begin{verbatim}+        (expr op)+\end{verbatim}+to+\begin{verbatim}+        \x -> op expr x+\end{verbatim}++But no!  expr might be a redex, and we can lose laziness badly this+way.  Consider+\begin{verbatim}+        map (expr op) xs+\end{verbatim}+for example.  So we convert instead to+\begin{verbatim}+        let y = expr in \x -> op y x+\end{verbatim}+If \tr{expr} is actually just a variable, say, then the simplifier+will sort it out.+-}++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 _ expr op)       -- Desugar (e !) to ((!) e)+  = do { op' <- dsLExpr op+       ; dsWhenNoErrs (dsLExprNoLP expr)+                      (\expr' -> mkCoreAppDs (text "sectionl" <+> ppr expr) op' expr') }++-- dsLExpr (SectionR op expr)   -- \ x -> op x expr+dsExpr e@(SectionR _ op expr) = do+    core_op <- dsLExpr op+    -- for the type of x, we need the type of op's 2nd argument+    let (x_ty:y_ty:_, _) = splitFunTys (exprType core_op)+        -- See comment with SectionL+    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]))++dsExpr (ExplicitTuple _ tup_args boxity)+  = do { let go (lam_vars, args) (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) (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 "dsExpr"++       ; 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)+  = do { dsWhenNoErrs (dsLExprNoLP expr)+                      (\core_expr -> mkCoreConApps (sumDataCon alt arity)+                                     (map (Type . getRuntimeRep) types +++                                      map Type types +++                                      [core_expr]) ) }++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 _ DoExpr        (L _ stmts)) = dsDo stmts+dsExpr (HsDo _ GhciStmtCtxt  (L _ stmts)) = dsDo stmts+dsExpr (HsDo _ MDoExpr       (L _ stmts)) = dsDo stmts+dsExpr (HsDo _ MonadComp     (L _ stmts)) = dsMonadComp stmts++dsExpr (HsIf _ fun guard_expr then_expr else_expr)+  = do { pred <- dsLExpr guard_expr+       ; b1 <- dsLExpr then_expr+       ; b2 <- dsLExpr else_expr+       ; case fun of  -- See Note [Rebindable if] in Hs.Expr+           (SyntaxExprTc {}) -> dsSyntaxExpr fun [pred, b1, b2]+           NoSyntaxExprTc    -> 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 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 (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.+-}++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 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.++-}++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 [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 (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) }++{- 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 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 (getLoc expr) flavour) count True)+               <$> dsLExpr expr+      else dsLExpr expr+ds_prag_expr (HsPragCore _ _ _) expr+  = dsLExpr expr+ds_prag_expr (HsPragTick _ _ _ _) expr = do+  dflags <- getDynFlags+  if gopt Opt_Hpc dflags+    then panic "dsExpr:HsPragTick"+    else dsLExpr expr+ds_prag_expr (XHsPragE x) _ = noExtCon x++------------------------------+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 = 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)+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+       ; 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 GHC.HsToCore.ListComp).  Basically does the translation given in the+Haskell 98 report:+-}++dsDo :: [ExprLStmt GhcTc] -> DsM CoreExpr+dsDo 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 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 <- dsHandleMonadicFailure 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 <- 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 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++dsHandleMonadicFailure :: LPat GhcTc -> MatchResult -> SyntaxExpr GhcTc -> DsM CoreExpr+    -- In a do expression, pattern-match failure just calls+    -- the monadic 'fail' rather than throwing an exception+dsHandleMonadicFailure 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 :: 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+               -- See Wrinkle in Note [Detecting forced eta expansion]+  = ASSERT2(null (badUseOfLevPolyPrimop var ty), ppr var $$ ppr ty)+    return (varToCoreExpr var)   -- See Note [Desugaring vars]++  where+    ty = idType var++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)+         ]++{-+************************************************************************+*                                                                      *+   Forced eta expansion and levity polymorphism+*                                                                      *+************************************************************************++Note [Detecting forced eta expansion]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We cannot have levity polymorphic function arguments. See+Note [Levity polymorphism invariants] in GHC.Core. 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, nor an HsPar.+This invariant is checked in dsExpr.+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+~~~~~~~+Currently, all levity-polymorphic Ids are wrapped in HsWrap.++However, this is not set in stone, in the future we might make+instantiation more lazy.  (See "Visible type application", ESOP '16.)+If we spot a levity-polymorphic hasNoBinding Id without a wrapper,+then that is surely a problem. In this case, we raise an assertion failure.+This failure can be changed to a call to `levPolyPrimopErr` in the future,+if we decide to change instantiation.++We can just check HsVar and HsConLikeOut for RealDataCon, since+we don't have levity-polymorphic pattern synonyms. (This might change+in the future.)+-}++-- | 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 -> SDoc -> Type -> DsM ()+checkForcedEtaExpansion expr expr_doc ty+  | Just var <- case expr of+                  HsVar _ (L _ var)               -> Just var+                  HsConLikeOut _ (RealDataCon dc) -> Just (dataConWrapId dc)+                  _                               -> Nothing+  , let bad_tys = badUseOfLevPolyPrimop var ty+  , not (null bad_tys)+  = levPolyPrimopErr expr_doc 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 :: SDoc -> Type -> [Type] -> DsM ()+levPolyPrimopErr expr_doc ty bad_tys+  = errDs $ vcat+    [ hang (text "Cannot use function with levity-polymorphic arguments:")+         2 (expr_doc <+> 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+    ]
+ compiler/GHC/HsToCore/Expr.hs-boot view
@@ -0,0 +1,12 @@+module GHC.HsToCore.Expr where+import GHC.Hs             ( HsExpr, LHsExpr, LHsLocalBinds, LPat, SyntaxExpr )+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 -> SyntaxExpr GhcTc -> DsM CoreExpr
+ compiler/GHC/HsToCore/Foreign/Call.hs view
@@ -0,0 +1,380 @@+{-+(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 GhcPrelude++import GHC.Core++import GHC.HsToCore.Monad+import GHC.Core.Utils+import GHC.Core.Make+import MkId+import ForeignCall+import DataCon+import GHC.HsToCore.Utils++import TcType+import Type+import Id   ( Id )+import Coercion+import PrimOp+import TysPrim+import TyCon+import TysWiredIn+import BasicTypes+import Literal+import PrelNames+import GHC.Driver.Session+import Outputable+import Util++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 { 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<r># 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 = (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 (mkIfThenElse arg (mkIntLit dflags 1) (mkIntLit dflags 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 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
+ compiler/GHC/HsToCore/Foreign/Decl.hs view
@@ -0,0 +1,820 @@+{-+(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 GhcPrelude++import TcRnMonad        -- temp++import GHC.Core++import GHC.HsToCore.Foreign.Call+import GHC.HsToCore.Monad++import GHC.Hs+import DataCon+import GHC.Core.Unfold+import Id+import Literal+import Module+import Name+import Type+import GHC.Types.RepType+import TyCon+import Coercion+import TcEnv+import TcType++import GHC.Cmm.Expr+import GHC.Cmm.Utils+import GHC.Driver.Types+import ForeignCall+import TysWiredIn+import TysPrim+import PrelNames+import BasicTypes+import SrcLoc+import Outputable+import FastString+import GHC.Driver.Session+import GHC.Platform+import OrdList+import Util+import GHC.Driver.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 @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+    fives <- mapM do_ldecl fos+    let+        (hs, cs, idss, bindss) = unzip4 fives+        fe_ids = concat idss+        fe_init_code = map foreignExportInitialiser fe_ids+    --+    return (ForeignStubs+             (vcat hs)+             (vcat cs $$ vcat fe_init_code),+            foldr (appOL . toOL) nilOL bindss)+  where+   do_ldecl (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 = 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], [])+   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  = coercionLKind 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 (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 :: 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 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 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 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'' <arg info> 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                       = coercionLKind 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+     ]+++foreignExportInitialiser :: Id -> SDoc+foreignExportInitialiser hs_fn =+   -- 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)+   vcat+    [ text "static void stginit_export_" <> ppr hs_fn+         <> text "() __attribute__((constructor));"+    , text "static void stginit_export_" <> ppr hs_fn <> text "()"+    , braces (text "foreignExportStablePtr"+       <> parens (text "(StgPtr) &" <> ppr hs_fn <> text "_closure")+       <> semi)+    ]+++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 :: 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 "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 :: DynFlags -> Type -> Char+primTyDescChar dflags 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)+       | wORD_SIZE dflags == 4  = ('W','w')+       | wORD_SIZE dflags == 8  = ('L','l')+       | otherwise              = panic "primTyDescChar"
+ compiler/GHC/HsToCore/GuardedRHSs.hs view
@@ -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 GhcPrelude++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 Type   ( Type )+import Util+import SrcLoc+import Outputable+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@.++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+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 }+dsGRHSs _ (XGRHSs nec) _ _ = noExtCon nec++dsGRHS :: HsMatchContext GhcRn -> Type -> Deltas -> LGRHS GhcTc (LHsExpr GhcTc)+       -> DsM MatchResult+dsGRHS hs_ctx rhs_ty rhs_deltas (L _ (GRHS _ guards rhs))+  = updPmDeltas rhs_deltas (matchGuards (map unLoc guards) (PatGuard hs_ctx) rhs rhs_ty)+dsGRHS _ _ _ (L _ (XGRHS nec)) = noExtCon nec++{-+************************************************************************+*                                                                      *+*  matchGuard : make a MatchResult from a guarded RHS                  *+*                                                                      *+************************************************************************+-}++matchGuards :: [GuardStmt GhcTc]     -- Guard+            -> HsStmtContext GhcRn   -- 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+    match_var <- selectMatchVar upat++    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 $ 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}+-}
+ compiler/GHC/HsToCore/ListComp.hs view
@@ -0,0 +1,676 @@+{-+(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 GhcPrelude++import {-# SOURCE #-} GHC.HsToCore.Expr ( dsHandleMonadicFailure, dsExpr, dsLExpr, dsLExprNoLP, dsLocalBinds, dsSyntaxExpr )++import GHC.Hs+import TcHsSyn+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 Id+import Type+import TysWiredIn+import GHC.HsToCore.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"++{-+************************************************************************+*                                                                      *+*           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 <<e>> TE <<L>>++(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)++{-+************************************************************************+*                                                                      *+*           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 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  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 ((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 <- 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) 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])) }
+ compiler/GHC/HsToCore/Match.hs view
@@ -0,0 +1,1164 @@+{-+(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 GhcPrelude++import {-#SOURCE#-} GHC.HsToCore.Expr (dsLExpr, dsSyntaxExpr)++import BasicTypes ( Origin(..) )+import GHC.Driver.Session+import GHC.Hs+import TcHsSyn+import TcEvidence+import TcRnMonad+import GHC.HsToCore.PmCheck+import GHC.Core+import 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 Id+import ConLike+import DataCon+import PatSyn+import GHC.HsToCore.Match.Constructor+import GHC.HsToCore.Match.Literal+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( 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 <binds>+in  <matching-code>+\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]+      -> 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 (v:vs) 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+    vars = v :| vs++    dropGroup :: Functor f => f (PatGroup,EquationInfo) -> f EquationInfo+    dropGroup = fmap snd++    match_groups :: [NonEmpty (PatGroup,EquationInfo)] -> DsM (NonEmpty MatchResult)+    -- Result list of [MatchResult] 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+    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)+-- 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 :: NonEmpty MatchId -> Type -> NonEmpty 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 $ NEL.toList $ shiftEqns eqns++matchBangs :: NonEmpty MatchId -> Type -> NonEmpty EquationInfo -> DsM MatchResult+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+-- 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 $ 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+-- 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 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+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 $ 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 (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 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++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 (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 (CoPat x w p t)+  = tidy1 v o (CoPat x 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@(ConPatOut { pat_con = 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 (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+                           []    -> mapM newSysLocalDsNoLP arg_tys+                           (m:_) -> selectMatchVars (map unLoc (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+      | XGRHSs nec <- grhss = noExtCon nec+      | 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' ) }+    mk_eqn_info (XMatch nec) _ = noExtCon nec++    handleWarnings = if isGenerated origin+                     then discardWarningsDs+                     else id+matchWrapper _ _ (XMatchGroup nec) = noExtCon nec++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 -> 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 GhcRn -> 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] -> [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 dflags eqns+  = NEL.groupBy same_gp $ [(patGroup dflags (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 (HsWrap h e)) (XExpr (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 (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 t1))   (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 = 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 _ (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 _ (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.+-}
+ compiler/GHC/HsToCore/Match.hs-boot view
@@ -0,0 +1,36 @@+module GHC.HsToCore.Match where++import GhcPrelude+import Var      ( Id )+import 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++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+        -> DsM MatchResult
+ compiler/GHC/HsToCore/Match/Constructor.hs view
@@ -0,0 +1,296 @@+{-+(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 GhcPrelude++import {-# SOURCE #-} GHC.HsToCore.Match ( match )++import GHC.Hs+import GHC.HsToCore.Binds+import ConLike+import BasicTypes ( Origin(..) )+import TcType+import GHC.HsToCore.Monad+import GHC.HsToCore.Utils+import GHC.Core.Make ( mkCoreLets )+import Util+import Id+import NameEnv+import FieldLabel ( flSelector )+import SrcLoc+import 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+-- 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"++matchPatSyn :: NonEmpty Id+            -> Type+            -> NonEmpty 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"++type ConArgPats = HsConDetails (LPat GhcTc) (HsRecFields GhcTc (LPat GhcTc))++matchOneConLike :: [Id]+                -> Type+                -> NonEmpty 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 = 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 (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 :: [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-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.+++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.++-}
+ compiler/GHC/HsToCore/Match/Literal.hs view
@@ -0,0 +1,522 @@+{-+(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 GhcPrelude++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 Id+import GHC.Core+import GHC.Core.Make+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 GHC.Driver.Session+import Util+import FastString+import qualified GHC.LanguageExtensions as LangExt++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+  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 bounds 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 (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 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 :: NonEmpty Id+              -> Type -- ^ Type of the whole case expression+              -> NonEmpty (NonEmpty EquationInfo) -- ^ All PgLits+              -> DsM MatchResult++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)+    match_group eqns@(firstEqn :| _)+        = do { dflags <- getDynFlags+             ; let LitPat _ hs_lit = firstPat firstEqn+             ; match_result <- match vars ty (NEL.toList $ 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)+++---------------------------+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 :: NonEmpty Id -> Type -> NonEmpty EquationInfo -> DsM MatchResult+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  <expr-for-a-successful-match>+    else+        <try-next-pattern-or-whatever>+\end{verbatim}+-}++matchNPlusKPats :: NonEmpty Id -> Type -> NonEmpty EquationInfo -> DsM MatchResult+-- 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)   $+                   adjustMatchResult (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)
+ compiler/GHC/HsToCore/Monad.hs view
@@ -0,0 +1,598 @@+{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998+++Monadery used in desugaring+-}++{-# LANGUAGE FlexibleInstances, FlexibleContexts #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}  -- instance MonadThings is necessarily an orphan+{-# LANGUAGE ViewPatterns #-}++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(..), DsWrapper, idDsWrapper,+        CanItFail(..), orFail,++        -- Levity polymorphism+        dsNoLevPoly, dsNoLevPolyExpr, dsWhenNoErrs,++        -- Trace injection+        pprRuntimeTrace+    ) where++import GhcPrelude++import TcRnMonad+import FamInstEnv+import GHC.Core+import GHC.Core.Make  ( unitExpr )+import GHC.Core.Utils ( exprType, isExprLevPoly )+import GHC.Hs+import GHC.IfaceToCore+import TcMType ( checkForLevPolyX, formatLevPolyErr )+import PrelNames+import RdrName+import GHC.Driver.Types+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 GHC.Driver.Session+import ErrUtils+import FastString+import UniqFM ( lookupWithDefaultUFM )+import Literal ( mkLitString )+import CostCentreState++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+              -- ^ 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_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 -> 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")  -- like newSysLocalDs, but we allow covars++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 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 :: [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_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. 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 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 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]
compiler/GHC/HsToCore/PmCheck.hs view
@@ -17,7 +17,7 @@         needToRunPmCheck, isMatchContextPmChecked,          -- See Note [Type and Term Equality Propagation]-        addTyCsDs, addScrutTmCs, addPatTmCs+        addTyCsDs, addScrutTmCs     ) where  #include "HsVersions.h"@@ -28,9 +28,9 @@ import GHC.HsToCore.PmCheck.Oracle import GHC.HsToCore.PmCheck.Ppr import BasicTypes (Origin, isGenerated)-import CoreSyn (CoreExpr, Expr(Var,App))+import GHC.Core (CoreExpr, Expr(Var,App)) import FastString (unpackFS, lengthFS)-import DynFlags+import GHC.Driver.Session import GHC.Hs import TcHsSyn import Id@@ -47,18 +47,19 @@ import Coercion import TcEvidence import TcType (evVarPred)-import {-# SOURCE #-} DsExpr (dsExpr, dsLExpr, dsSyntaxExpr)-import {-# SOURCE #-} DsBinds (dsHsWrapper)-import DsUtils (selectMatchVar)-import MatchLit (dsLit, dsOverLit)-import DsMonad+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 Bag import OrdList import TyCoRep import Type-import DsUtils       (isTrueLHsExpr)+import GHC.HsToCore.Utils       (isTrueLHsExpr) import Maybes import qualified GHC.LanguageExtensions as LangExt+import MonadUtils (concatMapM)  import Control.Monad (when, forM_, zipWithM) import Data.List (elemIndex)@@ -108,8 +109,8 @@     -- | @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.@@ -159,10 +160,11 @@ -- tree. 'redundantAndInaccessibleRhss' can figure out redundant and proper -- inaccessible RHSs from this. data AnnotatedTree-  = AccessibleRhs !RhsInfo-  -- ^ A RHS deemed accessible.+  = AccessibleRhs !Deltas !RhsInfo+  -- ^ A RHS deemed accessible. The 'Deltas' is the (non-empty) set of covered+  -- values.   | InaccessibleRhs !RhsInfo-  -- ^ A RHS deemed inaccessible; no value could possibly reach it.+  -- ^ 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.@@ -172,8 +174,8 @@   -- ^ Mirrors 'Empty' for preserving the skeleton of a 'GrdTree's.  pprRhsInfo :: RhsInfo -> SDoc-pprRhsInfo (L (RealSrcSpan rss) _) = ppr (srcSpanStartLine rss)-pprRhsInfo (L s _)                 = ppr s+pprRhsInfo (L (RealSrcSpan rss _) _) = ppr (srcSpanStartLine rss)+pprRhsInfo (L s _)                   = ppr s  instance Outputable GrdTree where   ppr (Rhs info)      = text "->" <+> pprRhsInfo info@@ -193,7 +195,7 @@   ppr Empty          = text "<empty case>"  instance Outputable AnnotatedTree where-  ppr (AccessibleRhs info)   = pprRhsInfo info+  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; ... }"@@ -203,17 +205,6 @@       collect_seqs t                 = [ppr t]   ppr EmptyAnn               = text "<empty case>" -newtype Deltas = MkDeltas (Bag Delta)--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)- -- | Lift 'addPmCts' over 'Deltas'. addPmCtsDeltas :: Deltas -> PmCts -> DsM Deltas addPmCtsDeltas deltas cts = liftDeltasM (\d -> addPmCts d cts) deltas@@ -271,7 +262,8 @@   -- Omitting checking this flag emits redundancy warnings twice in obscure   -- cases like #17646.   when (exhaustive dflags kind) $ do-    missing   <- MkDeltas . unitBag <$> getPmDelta+    -- 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@@ -279,12 +271,13 @@     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 = L combinedLoc $@@ -292,31 +285,62 @@                         , m_ctxt = hs_ctx                         , m_pats = []                         , m_grhss = guards }-    checkMatches dflags dsMatchContext [] [match]+    checkMatches dsMatchContext [] [match] checkGuardMatches _ (XGRHSs nec) = noExtCon nec --- | 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))) -  init_deltas <- MkDeltas . unitBag <$> getPmDelta+  init_deltas <- getPmDeltas   missing <- case matches of     -- This must be an -XEmptyCase. See Note [Checking EmptyCase]     [] | [var] <- vars -> addPmCtDeltas init_deltas (PmNotBotCt var)     _                  -> pure init_deltas-  tracePm "checkMatches: missing" (ppr missing)   fam_insts <- dsGetFamInstEnvs   grd_tree  <- mkGrdTreeMany [] <$> mapM (translateMatch fam_insts vars) matches   res <- checkGrdTree grd_tree missing    dsPmWarn dflags ctxt vars res +  return (extractRhsDeltas init_deltas (cr_clauses res))++-- | 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] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -XEmptyCase is useful for matching on empty data types like 'Void'. For example,@@ -483,7 +507,7 @@     translateConPatOut fam_insts x con arg_tys ex_tvs dicts ps    NPat ty (L _ olit) mb_neg _ -> do-    -- See Note [Literal short cut] in MatchLit.hs+    -- See Note [Literal short cut] in GHC.HsToCore.Match.Literal.hs     -- 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@@ -626,7 +650,7 @@ 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 . concat <$> mapM (translateGuard fam_insts . unLoc) gs+  mkGrdTreeRhs loc_sdoc <$> concatMapM (translateGuard fam_insts . unLoc) gs     where       loc_sdoc         | null gs   = L match_loc (sep (map ppr pats))@@ -920,7 +944,9 @@ -- RHS: Check that it covers something and wrap Inaccessible if not checkGrdTree' (Rhs sdoc) deltas = do   is_covered <- isInhabited deltas-  let clauses = if is_covered then AccessibleRhs sdoc else InaccessibleRhs sdoc+  let clauses+        | is_covered = AccessibleRhs deltas sdoc+        | otherwise  = InaccessibleRhs sdoc   pure CheckResult     { cr_clauses = clauses     , cr_uncov   = MkDeltas emptyBag@@ -983,8 +1009,8 @@ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 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@@ -1005,22 +1031,24 @@              (_:_) -> 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+locallyExtendPmDelta :: (Deltas -> DsM Deltas) -> DsM a -> DsM a+locallyExtendPmDelta ext k = getPmDeltas >>= ext >>= \deltas -> do+  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.-  Nothing     -> k-  Just delta' -> updPmDelta delta' k+  if inh+    then updPmDeltas deltas k+    else k  -- | Add in-scope type constraints addTyCsDs :: Bag EvVar -> DsM a -> DsM a addTyCsDs ev_vars =-  locallyExtendPmDelta (\delta -> addPmCts delta (PmTyCt . evVarPred <$> ev_vars))+  locallyExtendPmDelta (\deltas -> addPmCtsDeltas deltas (PmTyCt . evVarPred <$> ev_vars))  -- | Add equalities for the scrutinee to the local 'DsM' environment when -- checking a case expression:@@ -1031,51 +1059,9 @@ addScrutTmCs Nothing    _   k = k addScrutTmCs (Just scr) [x] k = do   scr_e <- dsLExpr scr-  locallyExtendPmDelta (\delta -> addPmCts delta (unitBag (PmCoreCt x scr_e))) k+  locallyExtendPmDelta (\deltas -> addPmCtsDeltas deltas (unitBag (PmCoreCt x scr_e))) k addScrutTmCs _   _   _ = panic "addScrutTmCs: HsCase with more than one case binder" -addPmConCts :: Delta -> Id -> PmAltCon -> [TyVar] -> [EvVar] -> [Id] -> DsM (Maybe Delta)-addPmConCts delta x con tvs dicts fields = runMaybeT $ do-  delta_ty    <- MaybeT $ addPmCts delta (listToBag (PmTyCt . evVarPred <$> dicts))-  delta_tm_ty <- MaybeT $ addPmCts delta_ty (unitBag (PmConCt x con tvs fields))-  pure delta_tm_ty---- | 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" <$> addPmCts delta (unitBag (PmCoreCt 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_tvs = tvs, pm_con_args = args-         , pm_con_dicts = dicts } <- p-  = addPmConCts delta x con tvs dicts args >>= \case-      Nothing     -> pure Nothing-      Just delta' -> computeCovered ps delta'- {- %************************************************************************ %*                                                                      *@@ -1114,7 +1100,7 @@     --       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 (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]@@ -1160,7 +1146,7 @@   = 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_i = flag_i && notNull inaccessible           exists_u = flag_u && notNull unc_examples           approx   = precision == Approximate @@ -1183,13 +1169,10 @@       , 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)@@ -1245,6 +1228,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@@ -1260,6 +1254,12 @@   , Opt_WarnIncompletePatternsRecUpd   , 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
compiler/GHC/HsToCore/PmCheck/Oracle.hs view
@@ -12,7 +12,7 @@ module GHC.HsToCore.PmCheck.Oracle (          DsM, tracePm, mkPmId,-        Delta, initDelta, lookupRefuts, lookupSolution,+        Delta, initDeltas, lookupRefuts, lookupSolution,          PmCt(PmTyCt), PmCts, pattern PmVarCt, pattern PmCoreCt,         pattern PmConCt, pattern PmNotConCt, pattern PmBotCt,@@ -29,7 +29,7 @@  import GHC.HsToCore.PmCheck.Types -import DynFlags+import GHC.Driver.Session import Outputable import ErrUtils import Util@@ -42,12 +42,12 @@ 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 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 UniqSupply import FastString import SrcLoc@@ -66,7 +66,7 @@ import TcRnTypes     (completeMatchConLikes) import Coercion import MonadUtils hiding (foldlM)-import DsMonad hiding (foldlM)+import GHC.HsToCore.Monad hiding (foldlM) import FamInst import FamInstEnv @@ -599,19 +599,19 @@   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@@ -620,8 +620,8 @@     @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] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -731,7 +731,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:@@ -890,26 +890,42 @@ -- | Adds a single term constraint by dispatching to the various term oracle -- functions. addTmCt :: Delta -> TmCt -> MaybeT DsM Delta-addTmCt delta (TmVarCt x y)            = addVarVarCt delta (x, y)-addTmCt delta (TmCoreCt x e)           = addVarCoreCt delta x e-addTmCt delta (TmConCt x con tvs args) = addVarConCt delta x con tvs args-addTmCt delta (TmNotConCt x con)       = addRefutableAltCon delta x con-addTmCt delta (TmBotCt x)              = addVarBotCt delta x-addTmCt delta (TmNotBotCt x)           = addVarNonVoidCt delta x+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 --- | In some future this will actually add a constraint to 'Delta' that we plan--- to preserve. But for now, we just check if we can add the constraint to the--- current 'Delta'. If so, we return the original 'Delta', if not, we fail.-addVarBotCt :: Delta -> Id -> MaybeT DsM Delta-addVarBotCt 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 --- | 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.+{- 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 -> MaybeT DsM Delta-addRefutableAltCon delta@MkDelta{ delta_tm_st = TmSt env reps } x nalt = 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, _tvs, _args) = eqPmAltCon cl nalt == Equal@@ -953,7 +969,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@@ -991,11 +1007,13 @@   subst <- tcMatchTy con_res_ty res_ty   traverse (lookupTyVar subst) univ_tvs --- | Kind of tries to add a non-void constraint 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.@@ -1066,15 +1084,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@@ -1106,22 +1125,23 @@         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, tvs, args) = addVarConCt delta y cl tvs 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 = addRefutableAltCon delta y nalt+        let add_refut delta nalt = addNotConCt 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+        -- 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 -> [TyVar] -> [Id] -> MaybeT DsM Delta-addVarConCt delta@MkDelta{ delta_tm_st = TmSt env reps } x alt tvs 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)@@ -1134,10 +1154,10 @@   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 = equateTyVarsCts tvs other_tvs+      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 "addVarConCt" PmVarCt args 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@@ -1146,13 +1166,14 @@       let pos' = (alt, tvs, args):pos       pure delta{ delta_tm_st = TmSt (setEntrySDIE env x (VI ty pos' neg' cache)) reps} -equateTyVarsCts :: [TyVar] -> [TyVar] -> [PmCt]-equateTyVarsCts as bs-  = map (\(a, b) -> PmTyCt $ mkPrimEqPred (mkTyVarTy a) (mkTyVarTy b))+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-  $ filter (uncurry (/=))-  $ zipEqual "equateTyVarsCts" as bs+  , not (eqType t u)+  ]  ---------------------------------------- -- * Enumerating inhabitation candidates@@ -1547,7 +1568,7 @@             y <- lift $ mkPmId arg_ty             -- Newtypes don't have existentials (yet?!), so passing an empty             -- list as ex_tvs.-            delta' <- addVarConCt delta x (PmAltConLike (RealDataCon dc)) [] [y]+            delta' <- addConCt delta x (PmAltConLike (RealDataCon dc)) [] [y]             pure (y, delta')       runMaybeT (foldlM build_newtype (x, delta) dcs) >>= \case         Nothing -> pure []@@ -1606,8 +1627,10 @@   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   | Just rep <- lookupCoreMap reps e = pure (delta, rep)@@ -1617,16 +1640,23 @@       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 -> MaybeT DsM Delta-addVarCoreCt delta x e = do+-- | 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 "addVarCoreCt" (ppr x $$ ppr e $$ ppr 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@@ -1646,30 +1676,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)             <- exprIsConApp_maybe in_scope_env e-      = do { let dc_ex_tvs               = dataConExTyCoVars dc-                 arty                    = dataConSourceArity dc-                 (_ex_ty_args, val_args) = splitAtList dc_ex_tvs 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-           -- See Note [Why we don't record existential type constraints]-           ; arg_ids <- traverse bind_expr vis_args-           ; data_con_app x dc ex_tvs 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)@@ -1679,50 +1700,58 @@         -- 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 -> [TyVar] -> [Id] -> StateT Delta (MaybeT DsM) ()-    data_con_app x dc tvs args = pm_alt_con_app x (PmAltConLike (RealDataCon dc)) tvs 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) [] []      -- | Adds the given constructor application as a solution for @x@.     pm_alt_con_app :: Id -> PmAltCon -> [TyVar] -> [Id] -> StateT Delta (MaybeT DsM) ()-    pm_alt_con_app x con tvs args = modifyT $ \delta -> addVarConCt delta x con tvs args+    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 () modifyT f = StateT $ fmap ((,) ()) . f -{- Note [Why we don't record existential type constraints]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-When we have--  data Ex where Ex :: a -> Ex-  f _ | let x = Ex @Int 15 = case x of Ex -> ...--we see that `Ex`'s existential in the `Ex` application in the RHS of `x` is-bound to `Int`. Eventually this application will run by `addVarCoreCt`,-which freshens `a` to `a'` and adds the constraint `x ~ Ex @a' 15`.--Now, we *could* add the constraint @a' ~ Int@, but that is never useful, because-types are irrelevant. And in fact, if the programmer assumed that @a' ~ Int@-in the case alt, it would be rejected as a type error. So we simply don't-include the constraint.--Note [Detecting pattern synonym applications in expressions]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+{- Note [Detecting pattern synonym applications in expressions]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ At the moment we fail to detect pattern synonyms in scrutinees and RHS of guards. This could be alleviated with considerable effort and complexity, but the returns are meager. Consider:
+ compiler/GHC/HsToCore/Quote.hs view
@@ -0,0 +1,2959 @@+{-# LANGUAGE CPP, TypeFamilies #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE UndecidableInstances #-}++{-# 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/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 GHC.HsToCore.Quote( dsBracket ) where++#include "HsVersions.h"++import GhcPrelude++import {-# SOURCE #-}   GHC.HsToCore.Expr ( dsExpr )++import GHC.HsToCore.Match.Literal+import GHC.HsToCore.Monad++import qualified Language.Haskell.TH as TH++import GHC.Hs+import PrelNames+-- To avoid clashes with GHC.HsToCore.Quote.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 GHC.Core+import GHC.Core.Make+import GHC.Core.Utils+import SrcLoc+import Unique+import BasicTypes+import Outputable+import Bag+import GHC.Driver.Session+import FastString+import ForeignCall+import Util+import Maybes+import MonadUtils+import TcEvidence+import Control.Monad.Trans.Reader+import Control.Monad.Trans.Class+import Class+import GHC.Driver.Types ( MonadThings )+import DataCon+import 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 = mkForAllTys tyvars $+                          mkInvisFunTy (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++-----------------------------------------------------------------------------+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 }+    do_brack (XBracket nec) = noExtCon nec++{-+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 `TcSplice`. 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 (L loc (Warning _ thing _))+      = notHandledL loc "WARNING and DEPRECATION pragmas" $+                    text "Pragma for declaration of" <+> ppr thing+    no_warn (L _ (XWarnDecl nec)) = noExtCon nec+    no_doc (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 (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 surprisingly 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 -> 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  <- 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 <- repListM decTyConName return (ats1 ++ atds1 ++ sigs_binds)+              ; decls2 <- repClass cxt1 cls1 bndrs fds1 decls1+              ; wrapGenSyms ss decls2 }+       ; return $ Just (loc, dec)+       }++repTyClD (L _ (XTyClDecl nec)) = noExtCon nec++-------------------------+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) }+repRoleD (L _ (XRoleAnnotDecl nec)) = noExtCon nec++-------------------------+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+    XStandaloneKindSig nec -> noExtCon nec++-------------------------+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 }+       }+repDataDefn _ _ (XHsDataDefn nec) = noExtCon nec++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)+       }+repFamilyDecl (L _ (XFamilyDecl nec)) = noExtCon nec++-- | 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' }+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+                              -> 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"+repFamilyResultSigToMaybeKind (XFamilyResultSig nec) = noExtCon nec++-- | 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) }+repInstD (L _ (XInstDecl nec)) = noExtCon nec++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 class and instance declarations]+               ; (ss, sigs_binds) <- rep_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+repClsInstD (XClsInstDecl nec) = noExtCon nec++repStandaloneDerivD :: LDerivDecl GhcRn -> MetaM (SrcSpan, Core (M TH.Dec))+repStandaloneDerivD (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 (L _ (XDerivDecl nec)) = noExtCon nec++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 tyVarBndrTyConName+                                        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"+repTyFamEqn (XHsImplicitBndrs nec) = noExtCon nec+repTyFamEqn (HsIB _ (XFamEqn nec)) = noExtCon nec++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 tyVarBndrTyConName+                                        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"++repDataFamInstD (DataFamInstDecl (XHsImplicitBndrs nec))+  = noExtCon nec+repDataFamInstD (DataFamInstDecl (HsIB _ (XFamEqn nec)))+  = noExtCon nec++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)+repForD (L _ (XForeignDecl nec)) = noExtCon nec++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 }+rep_fix_d _ (XFixitySig nec) = noExtCon nec++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 tyVarBndrTyConName+                         ; 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) }+repRuleD (L _ (XRuleDecl nec)) = noExtCon nec++ruleBndrNames :: LRuleBndr GhcRn -> [Name]+ruleBndrNames (L _ (RuleBndr _ n))      = [unLoc n]+ruleBndrNames (L _ (RuleBndrSig _ n sig))+  | HsWC { hswc_body = HsIB { hsib_ext = vars }} <- sig+  = unLoc n : vars+ruleBndrNames (L _ (RuleBndrSig _ _ (HsWC _ (XHsImplicitBndrs nec))))+  = noExtCon nec+ruleBndrNames (L _ (RuleBndrSig _ _ (XHsWildCardBndrs nec)))+  = noExtCon nec+ruleBndrNames (L _ (XRuleBndr nec)) = noExtCon nec++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 (hsSigWcType sig)+       ; rep2 typedRuleVarName [n', ty'] }+repRuleBndr (L _ (XRuleBndr nec)) = noExtCon nec++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) }+repAnnD (L _ (XAnnDecl nec)) = noExtCon nec++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_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 (L _ (XConDecl nec)) = noExtCon nec+++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 }))+  = do MkC dcs' <- repDerivStrategy dcs+       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+repDerivClause (L _ (XHsDerivingClause nec)) = noExtCon nec++rep_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 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] -> 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+rep_sig (L _ (XSig nec)) = noExtCon nec++rep_ty_sig :: Name -> SrcSpan -> LHsSigType GhcRn -> Located Name+           -> MetaM (SrcSpan, Core (M TH.Dec))+-- 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 <- repListM tyVarBndrTyConName 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+                  -> MetaM (SrcSpan, Core (M TH.Dec))+-- 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 <- repListM tyVarBndrTyConName rep_in_scope_tv univs+       ; th_exis  <- repListM tyVarBndrTyConName 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+              -> 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+-------------------------------------------------------++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 :: [LHsTyVarBndr GhcRn]  -- the binders to be added+                -> (Core [(M TH.TyVarBndr)] -> 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 tyVarBndrTyConName 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 [(M TH.TyVarBndr)] -> 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 (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 [(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 tyVarBndrTyConName 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 :: LHsTyVarBndr GhcRn+                     -> Core TH.Name -> MetaM (Core (M TH.TyVarBndr))+repTyVarBndrWithKind (L _ (UserTyVar _ _)) nm+  = repPlainTV nm+repTyVarBndrWithKind (L _ (KindedTyVar _ _ ki)) nm+  = repLTy ki >>= repKindedTV nm+repTyVarBndrWithKind (L _ (XTyVarBndr nec)) _ = noExtCon nec++-- | Represent a type variable binder+repTyVarBndr :: LHsTyVarBndr GhcRn -> MetaM (Core (M TH.TyVarBndr))+repTyVarBndr (L _ (UserTyVar _ (L _ nm)) )+  = do { nm' <- lookupBinder nm+       ; repPlainTV nm' }+repTyVarBndr (L _ (KindedTyVar _ (L _ nm) ki))+  = do { nm' <- lookupBinder nm+       ; ki' <- repLTy ki+       ; repKindedTV nm' ki' }+repTyVarBndr (L _ (XTyVarBndr nec)) = noExtCon nec++-- 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 }+repHsSigType (XHsImplicitBndrs nec) = noExtCon nec++repHsSigWcType :: LHsSigWcType GhcRn -> MetaM (Core (M TH.Type))+repHsSigWcType (HsWC { hswc_body = sig1 })+  = repHsSigType sig1+repHsSigWcType (XHsWildCardBndrs nec) = noExtCon nec++-- 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 ForallInvis@ 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_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 _ _ (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 -> MetaM (Core (M TH.TyLit))+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)+            -> 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 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 (XSplice nec)             = noExtCon nec++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)+  XAmbiguousFieldOcc nec -> noExtCon nec++        -- 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))+ | 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 -> 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 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 uv+                               sname <- repNameS occ+                               repUnboundVar sname++repE e@(HsPragE _ HsPragCore {} _)   = notHandled "Core annotations" (ppr e)+repE e@(HsPragE _ HsPragSCC  {} _)   = notHandled "Cost centres" (ppr e)+repE e@(HsPragE _ HsPragTick {} _)   = notHandled "Tick Pragma" (ppr e)+repE (XExpr nec)           = noExtCon nec+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 }}}+repClauseTup (L _ (Match _ _ _ (XGRHSs nec))) = noExtCon nec+repClauseTup (L _ (XMatch nec)) = noExtCon nec++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) }+repLGRHS (L _ (XGRHS nec)) = noExtCon nec++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)+      XAmbiguousFieldOcc nec -> noExtCon nec++++-----------------------------------------------------------------------------+-- 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 [ 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) }+     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 (XStmtLR nec : _) = noExtCon nec+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 (HsIPBinds _ (XHsIPBinds nec)) = noExtCon nec++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 <- coreListM decTyConName+                                (de_loc (sort_by_loc prs))+        ; return (ss, core_list) }+repBinds (XHsLocalBindsLR nec) = noExtCon nec++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_bind (L _ (XIPBind nec)) = noExtCon nec++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 _ (FunBind { fun_matches = XMatchGroup nec })) = noExtCon nec++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 _ (PatBind _ _ (XGRHSs nec) _)) = noExtCon nec++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++rep_bind (L _ (PatSynBind _ (XPatSynBind nec))) = noExtCon nec+rep_bind (L _ (XHsBindsLR nec)) = noExtCon nec++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') }+repPatSynDir (ExplicitBidirectional (XMatchGroup nec)) = noExtCon nec++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 _ (Match { m_grhss = GRHSs _ [L _ (GRHS _ [] _)]+                                          (L _ (XHsLocalBindsLR nec)) } ))+ = noExtCon nec++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 (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 <- 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 (hsSigWcType t)+                         ; repPsig p' t' }+repP (SplicePat _ splice) = repSplice splice+repP (XPat nec) = noExtCon nec+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) 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 <module>:<name> 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 = 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 "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 { dflags <- getDynFlags+      ; rep2 unboxedSumPName [ p+                             , mkIntExprInt dflags alt+                             , mkIntExprInt dflags 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 { dflags <- getDynFlags+      ; rep2 unboxedSumEName [ e+                             , mkIntExprInt dflags alt+                             , mkIntExprInt dflags 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 :: Core [(M TH.Stmt)] -> MetaM (Core (M TH.Exp))+repDoE (MkC ss) = rep2 doEName [ss]++repMDoE :: Core [(M TH.Stmt)] -> MetaM (Core (M TH.Exp))+repMDoE (MkC ss) = rep2 mdoEName [ss]++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)+                 -> MetaM (Core (Maybe (M TH.DerivStrategy)))+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 = 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 ps+         rep2 normalCName [unC con, unC arg_tys]++repConstr (PrefixCon ps) (Just res_ty) cons+    = do arg_tys     <- repListM bangTypeTyConName 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 <- 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 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 [(M TH.TyVarBndr)] -> 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 dflags <- getDynFlags+                     rep2 tupleTName [mkIntExprInt dflags i]++repUnboxedTupleTyCon :: Int -> MetaM (Core (M TH.Type))+-- Note: not Core Int; it's easier to be direct here+repUnboxedTupleTyCon i = do dflags <- getDynFlags+                            rep2 unboxedTupleTName [mkIntExprInt dflags i]++repUnboxedSumTyCon :: TH.SumArity -> MetaM (Core (M TH.Type))+-- Note: not Core TH.SumArity; it's easier to be direct here+repUnboxedSumTyCon arity = do dflags <- getDynFlags+                              rep2 unboxedSumTName [mkIntExprInt dflags arity]++repArrowTyCon :: MetaM (Core (M TH.Type))+repArrowTyCon = rep2 arrowTName []++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 dflags <- getDynFlags+                             rep2 promotedTupleTName [mkIntExprInt dflags i]++repPromotedNilTyCon :: MetaM (Core (M TH.Type))+repPromotedNilTyCon = rep2 promotedNilTName []++repPromotedConsTyCon :: MetaM (Core (M TH.Type))+repPromotedConsTyCon = rep2 promotedConsTName []++------------ TyVarBndrs -------------------++repPlainTV :: Core TH.Name -> MetaM (Core (M TH.TyVarBndr))+repPlainTV (MkC nm) = rep2 plainTVName [nm]++repKindedTV :: Core TH.Name -> Core (M TH.Kind) -> MetaM (Core (M TH.TyVarBndr))+repKindedTV (MkC nm) (MkC ki) = rep2 kindedTVName [nm, ki]++----------------------------------------------------------+--       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 dflags   <- getDynFlags+       word8_ty <- lookupType word8TyConName+       let w8s = unpack bs+           w8s_expr = map (\w8 -> mkCoreConApps word8DataCon+                                  [mkWordLit dflags (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 = do integer_ty <- lookupType integerTyConName+                   return $ HsInteger NoSourceText i integer_ty++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+repOverloadedLiteral (XOverLit nec) = noExtCon nec++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 dflags <- getDynFlags+                  return (MkC (mkIntExprInt dflags i))++coreIntegerLit :: MonadThings m => Integer -> m (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 -> 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
+ compiler/GHC/HsToCore/Usage.hs view
@@ -0,0 +1,375 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE ViewPatterns #-}++{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}++module GHC.HsToCore.Usage (+    -- * Dependency/fingerprinting code (used by GHC.Iface.Utils)+    mkUsageInfo, mkUsedNames, mkDependencies+    ) where++#include "HsVersions.h"++import GhcPrelude++import GHC.Driver.Session+import GHC.Driver.Types+import TcRnTypes+import Name+import NameSet+import Module+import Outputable+import Util+import UniqSet+import UniqFM+import Fingerprint+import Maybes+import GHC.Driver.Packages+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 :: 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 [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 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!+        -}
+ compiler/GHC/HsToCore/Utils.hs view
@@ -0,0 +1,1001 @@+{-+(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 GHC.HsToCore.Utils (+        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 #-} GHC.HsToCore.Match ( matchSimply )+import {-# SOURCE #-} GHC.HsToCore.Expr  ( dsLExpr )++import GHC.Hs+import TcHsSyn+import TcType( tcSplitTyConApp )+import GHC.Core+import GHC.HsToCore.Monad++import GHC.Core.Utils+import GHC.Core.Make+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 GHC.Driver.Session+import FastString+import qualified GHC.LanguageExtensions as LangExt++import TcEvidence++import Control.Monad    ( zipWithM )+import Data.List.NonEmpty (NonEmpty(..))+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.+-}++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 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 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+  -> NonEmpty (CaseAlt DataCon) -- ^ Alternatives (bndrs *include* tyvars, dicts)+  -> MatchResult+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+mkCoSynCaseMatchResult var ty alt = MatchResult CanFail $ 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]+    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 -> NonEmpty (CaseAlt DataCon) -> MatchResult+mkDataConCase var ty alts@(alt1 :| _) = MatchResult fail_flag mk_case+  where+    con1          = alt_pat alt1+    tycon         = dataConTyCon con1+    data_cons     = tyConDataCons tycon+    match_results = fmap alt_result alts++    sorted_alts :: NonEmpty (CaseAlt DataCon)+    sorted_alts  = NEL.sortWith (dataConTag . alt_pat) 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 ++ NEL.toList 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 _ <- NEL.toList match_results]+              | otherwise+              = CanFail++    mentioned_constructors = mkUniqSet $ map alt_pat $ NEL.toList 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 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) -> 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 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 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 (L _ (ParPat _ p))  = strip_bangs p+strip_bangs (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  = 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 :: [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 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)++-- | Unconditionally make a 'Pat' strict.+addBang :: LPat GhcTc -- ^ Original pattern+        -> LPat GhcTc -- ^ Banged pattern+addBang = go+  where+    go lp@(L l p)+      = case p of+           ParPat x p    -> L l (ParPat x (go p))+           LazyPat _ lp' -> L l (BangPat noExtField lp')+                                  -- Should we bring the extension value over?+           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
compiler/GHC/Iface/Binary.hs view
@@ -38,10 +38,10 @@ import TcRnMonad import PrelInfo   ( isKnownKeyName, lookupKnownKeyName ) import GHC.Iface.Env-import HscTypes+import GHC.Driver.Types import Module import Name-import DynFlags+import GHC.Driver.Session import UniqFM import UniqSupply import Panic
compiler/GHC/Iface/Env.hs view
@@ -25,7 +25,7 @@ import GhcPrelude  import TcRnMonad-import HscTypes+import GHC.Driver.Types import Type import Var import Name
compiler/GHC/Iface/Ext/Ast.hs view
@@ -12,10 +12,9 @@ {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE DeriveDataTypeable #-}- {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} -module GHC.Iface.Ext.Ast ( mkHieFile ) where+module GHC.Iface.Ext.Ast ( mkHieFile, mkHieFileWithSource, getCompressedAsts) where  import GhcPrelude @@ -24,12 +23,12 @@ import BasicTypes import BooleanFormula import Class                      ( FunDep )-import CoreUtils                  ( exprType )+import GHC.Core.Utils             ( exprType ) import ConLike                    ( conLikeName )-import Desugar                    ( deSugarExpr )+import GHC.HsToCore               ( deSugarExpr ) import FieldLabel import GHC.Hs-import HscTypes+import GHC.Driver.Types import Module                     ( ModuleName, ml_hs_file ) import MonadUtils                 ( concatMapM, liftIO ) import Name                       ( Name, nameSrcSpan, setNameLoc )@@ -42,6 +41,7 @@ import TcRnTypes import GHC.Iface.Utils            ( mkIfaceExports ) import Panic+import Maybes  import GHC.Iface.Ext.Types import GHC.Iface.Ext.Utils@@ -52,7 +52,6 @@ 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 ) @@ -226,10 +225,20 @@           -> 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   (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@@ -288,7 +297,7 @@       ]  getRealSpan :: SrcSpan -> Maybe Span-getRealSpan (RealSrcSpan sp) = Just sp+getRealSpan (RealSrcSpan sp _) = Just sp getRealSpan _ = Nothing  grhss_span :: GRHSs p body -> SrcSpan@@ -298,7 +307,7 @@ bindingsOnly :: [Context Name] -> [HieAST a] bindingsOnly [] = [] bindingsOnly (C c n : xs) = case nameSrcSpan n of-  RealSrcSpan span -> Node nodeinfo span [] : bindingsOnly xs+  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@@ -522,7 +531,7 @@   toHie _ = pure []  instance ToHie (IEContext (Located ModuleName)) where-  toHie (IEC c (L (RealSrcSpan span) mname)) =+  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@@ -530,7 +539,7 @@  instance ToHie (Context (Located Var)) where   toHie c = case c of-      C context (L (RealSrcSpan span) name')+      C context (L (RealSrcSpan span _) name')         -> do         m <- asks name_remapping         let name = case lookupNameEnv m (varName name') of@@ -548,7 +557,7 @@  instance ToHie (Context (Located Name)) where   toHie c = case c of-      C context (L (RealSrcSpan span) name') -> do+      C context (L (RealSrcSpan span _) name') -> do         m <- asks name_remapping         let name = case lookupNameEnv m name' of               Just var -> varName var@@ -643,16 +652,16 @@       -- 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 :: HsExpr GhcTc -> Bool       skipDesugaring e = case e of-        HsVar{}        -> False-        HsUnboundVar{} -> False-        HsConLikeOut{} -> False-        HsRecFld{}     -> False-        HsOverLabel{}  -> False-        HsIPVar{}      -> False-        HsWrap{}       -> False-        _              -> True+        HsVar{}          -> False+        HsUnboundVar{}   -> False+        HsConLikeOut{}   -> False+        HsRecFld{}       -> False+        HsOverLabel{}    -> False+        HsIPVar{}        -> False+        XExpr (HsWrap{}) -> False+        _                -> True  instance ( ToHie (Context (Located (IdP a)))          , ToHie (MatchGroup a (LHsExpr a))@@ -732,7 +741,7 @@  instance ( a ~ GhcPass p          , ToHie body-         , ToHie (HsMatchContext (NameOrRdrName (IdP a)))+         , ToHie (HsMatchContext (NoGhcTc a))          , ToHie (PScoped (LPat a))          , ToHie (GRHSs a body)          , Data (Match a body)@@ -746,7 +755,7 @@       ]     XMatch _ -> [] -instance ( ToHie (Context (Located a))+instance ( ToHie (Context (Located (IdP a)))          ) => ToHie (HsMatchContext a) where   toHie (FunRhs{mc_fun=name}) = toHie $ C MatchBind name   toHie (StmtCtxt a) = toHie a@@ -768,6 +777,7 @@          , ToHie (TScoped (ProtectedSig a))          , HasType (LPat a)          , Data (HsSplice a)+         , IsPass p          ) => ToHie (PScoped (Located (Pat (GhcPass p)))) where   toHie (PS rsp scope pscope lpat@(L ospan opat)) =     concatM $ getTypeNode lpat : case opat of@@ -885,6 +895,7 @@          , Data (HsTupArg a)          , Data (AmbiguousFieldOcc a)          , (HasRealDataConName a)+         , IsPass p          ) => ToHie (LHsExpr (GhcPass p)) where   toHie e@(L mspan oexpr) = concatM $ getTypeNode e : case oexpr of       HsVar _ (L _ var) ->@@ -997,9 +1008,6 @@       HsBinTick _ _ _ expr ->         [ toHie expr         ]-      HsWrap _ _ a ->-        [ toHie $ L mspan a-        ]       HsBracket _ b ->         [ toHie b         ]@@ -1014,8 +1022,14 @@       HsSpliceE _ x ->         [ toHie $ L mspan x         ]-      XExpr _ -> []+      XExpr x+        | GhcTc <- ghcPass @p+        , HsWrap _ a <- x+        -> [ toHie $ L mspan a ] +        | otherwise+        -> []+ instance ( a ~ GhcPass p          , ToHie (LHsExpr a)          , Data (HsTupArg a)@@ -1244,7 +1258,6 @@         [ pure $ locOnly ispan         , toHie $ listScopes NoScope stmts         ]-      HsCmdWrap _ _ _ -> []       XCmd _ -> []  instance ToHie (TyClGroup GhcRn) where@@ -1686,8 +1699,10 @@ instance ToHie (Located HsIPName) where   toHie (L span e) = makeNode e span -instance ( ToHie (LHsExpr a)+instance ( a ~ GhcPass p+         , ToHie (LHsExpr a)          , Data (HsSplice a)+         , IsPass p          ) => ToHie (Located (HsSplice a)) where   toHie (L span sp) = concatM $ makeNode sp span : case sp of       HsTypedSplice _ _ _ expr ->@@ -1701,9 +1716,11 @@         ]       HsSpliced _ _ _ ->         []-      HsSplicedT _ ->-        []-      XSplice _ -> []+      XSplice x -> case ghcPass @p of+                     GhcPs -> noExtCon x+                     GhcRn -> noExtCon x+                     GhcTc -> case x of+                                HsSplicedT _ -> []  instance ToHie (LRoleAnnotDecl GhcRn) where   toHie (L span annot) = concatM $ makeNode annot span : case annot of
compiler/GHC/Iface/Ext/Binary.hs view
@@ -32,6 +32,7 @@ import UniqSupply                 ( takeUniqFromSupply ) import Unique import UniqFM+import Util  import qualified Data.Array as A import Data.IORef@@ -56,8 +57,10 @@   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 (ExternalName a b c) (ExternalName d e f) = compare (a,b) (d,e) `thenCmp` SrcLoc.leftmost_smallest c f+    -- TODO (int-index): Perhaps use RealSrcSpan in HieName?+  compare (LocalName a b) (LocalName c d) = compare a c `thenCmp` SrcLoc.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
compiler/GHC/Iface/Ext/Utils.hs view
@@ -6,12 +6,12 @@  import GhcPrelude -import CoreMap-import DynFlags                   ( DynFlags )+import GHC.Core.Map+import GHC.Driver.Session         ( DynFlags ) import FastString                 ( FastString, mkFastString ) import GHC.Iface.Type import Name hiding (varName)-import Outputable                 ( renderWithStyle, ppr, defaultUserStyle )+import Outputable                 ( renderWithStyle, ppr, defaultUserStyle, initSDocContext ) import SrcLoc import GHC.CoreToIface import TyCon@@ -44,7 +44,7 @@         this = fmap (pure . (nodeSpan ast,)) $ nodeIdentifiers $ nodeInfo ast  renderHieType :: DynFlags -> HieTypeFix -> String-renderHieType df ht = renderWithStyle df (ppr $ hieTypeToIface ht) sty+renderHieType df ht = renderWithStyle (initSDocContext df sty) (ppr $ hieTypeToIface ht)   where sty = defaultUserStyle df  resolveVisibility :: Type -> [Type] -> [(Bool,Type)]@@ -227,7 +227,7 @@   -> M.Map FastString (HieAST a)   -> Maybe ([Scope], Maybe Span) getNameScopeAndBinding n asts = case nameSrcSpan n of-  RealSrcSpan sp -> do -- @Maybe+  RealSrcSpan sp _ -> do -- @Maybe     ast <- M.lookup (srcSpanFile sp) asts     defNode <- selectLargestContainedBy sp ast     getFirst $ foldMap First $ do -- @[]@@ -290,7 +290,7 @@  definedInAsts :: M.Map FastString (HieAST a) -> Name -> Bool definedInAsts asts n = case nameSrcSpan n of-  RealSrcSpan sp -> srcSpanFile sp `elem` M.keys asts+  RealSrcSpan sp _ -> srcSpanFile sp `elem` M.keys asts   _ -> False  isOccurrence :: ContextInfo -> Bool@@ -406,13 +406,13 @@ simpleNodeInfo cons typ = NodeInfo (S.singleton (cons, typ)) [] M.empty  locOnly :: SrcSpan -> [HieAST a]-locOnly (RealSrcSpan span) =+locOnly (RealSrcSpan span _) =   [Node e span []]     where e = NodeInfo S.empty [] M.empty locOnly _ = []  mkScope :: SrcSpan -> Scope-mkScope (RealSrcSpan sp) = LocalScope sp+mkScope (RealSrcSpan sp _) = LocalScope sp mkScope _ = NoScope  mkLScope :: Located a -> Scope@@ -424,7 +424,7 @@ combineScopes NoScope x = x combineScopes x NoScope = x combineScopes (LocalScope a) (LocalScope b) =-  mkScope $ combineSrcSpans (RealSrcSpan a) (RealSrcSpan b)+  mkScope $ combineSrcSpans (RealSrcSpan a Nothing) (RealSrcSpan b Nothing)  {-# INLINEABLE makeNode #-} makeNode@@ -433,7 +433,7 @@   -> 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 []]+  RealSrcSpan span _ -> [Node (simpleNodeInfo cons typ) span []]   _ -> []   where     cons = mkFastString . show . toConstr $ x@@ -447,7 +447,7 @@   -> Type                    -- ^ type to associate with the node   -> m [HieAST Type] makeTypeNode x spn etyp = pure $ case spn of-  RealSrcSpan span ->+  RealSrcSpan span _ ->     [Node (NodeInfo (S.singleton (cons,typ)) [etyp] M.empty) span []]   _ -> []   where
compiler/GHC/Iface/Load.hs view
@@ -40,10 +40,10 @@    ( tcIfaceDecl, tcIfaceRules, tcIfaceInst, tcIfaceFamInst    , tcIfaceAnnotations, tcIfaceCompleteSigs ) -import DynFlags+import GHC.Driver.Session import GHC.Iface.Syntax import GHC.Iface.Env-import HscTypes+import GHC.Driver.Types  import BasicTypes hiding (SuccessFlag(..)) import TcRnMonad@@ -54,7 +54,7 @@ import PrimOp   ( allThePrimOps, primOpFixity, primOpOcc ) import MkId     ( seqId ) import TysPrim  ( funTyConName )-import Rules+import GHC.Core.Rules import TyCon import Annotations import InstEnv@@ -65,7 +65,7 @@ import Module import Maybes import ErrUtils-import Finder+import GHC.Driver.Finder import UniqFM import SrcLoc import Outputable@@ -74,11 +74,11 @@ import Util import FastString import Fingerprint-import Hooks+import GHC.Driver.Hooks import FieldLabel import GHC.Iface.Rename import UniqDSet-import Plugins+import GHC.Driver.Plugins  import Control.Monad import Control.Exception@@ -525,8 +525,9 @@                                                    (length new_eps_insts)                                                    (length new_eps_rules) } -        ; -- invoke plugins-          res <- withPlugins dflags interfaceLoadAction final_iface+        ; -- invoke plugins with *full* interface, not final_iface, to ensure+          -- that plugins have access to declarations, etc.+          res <- withPlugins dflags interfaceLoadAction iface         ; return (Succeeded res)     }}}} @@ -751,9 +752,7 @@           -> [(Fingerprint, IfaceDecl)]           -> IfL [(Name,TyThing)] loadDecls ignore_prags ver_decls-   = do { thingss <- mapM (loadDecl ignore_prags) ver_decls-        ; return (concat thingss)-        }+   = concatMapM (loadDecl ignore_prags) ver_decls  loadDecl :: Bool                    -- Don't load pragmas into the decl pool           -> (Fingerprint, IfaceDecl)@@ -865,7 +864,7 @@ 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).+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,
compiler/GHC/Iface/Load.hs-boot view
@@ -2,7 +2,7 @@  import Module (Module) import TcRnMonad (IfM)-import HscTypes (ModIface)+import GHC.Driver.Types (ModIface) import Outputable (SDoc)  loadSysInterface :: SDoc -> Module -> IfM lcl ModIface
compiler/GHC/Iface/Rename.hs view
@@ -21,7 +21,7 @@  import SrcLoc import Outputable-import HscTypes+import GHC.Driver.Types import Module import UniqFM import Avail@@ -38,13 +38,13 @@  -- a bit vexing import {-# SOURCE #-} GHC.Iface.Load-import DynFlags+import GHC.Driver.Session  import qualified Data.Traversable as T  import Bag import Data.IORef-import NameShape+import GHC.Types.Name.Shape import GHC.Iface.Env  tcRnMsgMaybe :: IO (Either ErrorMessages a) -> TcM a@@ -592,8 +592,7 @@              , ifaxbRHS = rhs }  rnIfaceIdInfo :: Rename IfaceIdInfo-rnIfaceIdInfo NoInfo = pure NoInfo-rnIfaceIdInfo (HasInfo is) = HasInfo <$> mapM rnIfaceInfoItem is+rnIfaceIdInfo = mapM rnIfaceInfoItem  rnIfaceInfoItem :: Rename IfaceInfoItem rnIfaceInfoItem (HsUnfold lb if_unf)
compiler/GHC/Iface/Tidy.hs view
@@ -17,22 +17,19 @@ import GhcPrelude  import TcRnTypes-import DynFlags-import CoreSyn-import CoreUnfold-import CoreFVs-import CoreTidy+import GHC.Driver.Session+import GHC.Core+import GHC.Core.Unfold+import GHC.Core.FVs+import GHC.Core.Op.Tidy import CoreMonad-import GHC.CoreToStg.Prep-import CoreUtils        (rhsIsStatic)-import CoreStats        (coreBindsStats, CoreStats(..))-import CoreSeq          (seqBinds)-import CoreLint-import Literal-import Rules+import GHC.Core.Stats   (coreBindsStats, CoreStats(..))+import GHC.Core.Seq     (seqBinds)+import GHC.Core.Lint+import GHC.Core.Rules import PatSyn import ConLike-import CoreArity        ( exprArity, exprBotStrictness_maybe )+import GHC.Core.Arity   ( exprArity, exprBotStrictness_maybe ) import StaticPtrTable import VarEnv import VarSet@@ -43,6 +40,7 @@ import InstEnv import Type             ( tidyTopType ) import Demand           ( appIsBottom, isTopSig, isBottomingSig )+import Cpr              ( mkCprSig, botCpr ) import BasicTypes import Name hiding (varName) import NameSet@@ -55,8 +53,7 @@ import TyCon import Class import Module-import Packages( isDllName )-import HscTypes+import GHC.Driver.Types import Maybes import UniqSupply import Outputable@@ -119,7 +116,7 @@  * Drop rules altogether -* Tidy the bindings, to ensure that the Caf and Arity+* 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@@ -217,7 +214,7 @@ -- makes it into a GlobalId --     * unchanged Name (might be Internal or External) --     * unchanged details---     * VanillaIdInfo (makes a conservative assumption about Caf-hood and arity)+--     * VanillaIdInfo (makes a conservative assumption about arity) --     * BootUnfolding (see Note [Inlining and hs-boot files] in GHC.CoreToIface) globaliseAndTidyBootId id   = globaliseId id `setIdType`      tidyTopType (idType id)@@ -316,9 +313,7 @@          * 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.@@ -359,7 +354,7 @@                     = findExternalRules omit_prags binds imp_rules unfold_env }          ; (tidy_env, tidy_binds)-                 <- tidyTopBinds hsc_env mod unfold_env tidy_occ_env trimmed_binds+                 <- tidyTopBinds hsc_env unfold_env tidy_occ_env trimmed_binds            -- See Note [Grand plan for static forms] in StaticPtrTable.         ; (spt_entries, tidy_binds') <-@@ -459,8 +454,15 @@ trimId id   | not (isImplicitId id)   = id `setIdInfo` vanillaIdInfo+       `setIdUnfolding` unfolding   | otherwise   = id+  where+    unfolding+      | isCompulsoryUnfolding (idUnfolding id)+      = idUnfolding id+      | otherwise+      = noUnfolding  {- Note [Drop wired-in things] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -503,14 +505,14 @@  Note [Injecting implicit bindings] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We inject the implicit bindings right at the end, in CoreTidy.+We inject the implicit bindings right at the end, in GHC.Core.Op.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 CoreUnfold.mkImplicitUnfolding uses simpleOptExpr to do a bit of+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. @@ -1070,22 +1072,13 @@ --   * 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+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@@ -1093,35 +1086,28 @@      init_env = (init_occ_env, emptyVarEnv) -    tidy cvt_literal = mapAccumL (tidyTopBind dflags this_mod cvt_literal unfold_env)+    tidy = mapAccumL (tidyTopBind dflags unfold_env)  ------------------------ tidyTopBind  :: DynFlags-             -> Module-             -> (LitNumType -> Integer -> Maybe CoreExpr)              -> UnfoldEnv              -> TidyEnv              -> CoreBind              -> (TidyEnv, CoreBind) -tidyTopBind dflags this_mod cvt_literal unfold_env+tidyTopBind dflags 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)+    (bndr', rhs') = tidyTopPair dflags show_unfold tidy_env2 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)+tidyTopBind dflags unfold_env (occ_env, subst1) (Rec prs)   = (tidy_env2, Rec prs')   where-    prs' = [ tidyTopPair dflags show_unfold tidy_env2 caf_info name' (id,rhs)+    prs' = [ tidyTopPair dflags show_unfold tidy_env2 name' (id,rhs)            | (id,rhs) <- prs,              let (name',show_unfold) =                     expectJust "tidyTopBind" $ lookupVarEnv unfold_env id@@ -1132,21 +1118,11 @@      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)@@ -1156,7 +1132,7 @@         -- 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)+tidyTopPair dflags show_unfold rhs_tidy_env name' (bndr, rhs)   = (bndr1, rhs1)   where     bndr1    = mkGlobalId details name' ty' idinfo'@@ -1164,38 +1140,33 @@     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+                             show_unfold  -- tidyTopIdInfo creates the final IdInfo for top-level--- binders.  There are two delicate pieces:+-- 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. -----  * 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+              -> 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. CoreTidy.tidyLetBndr-        `setCafInfo`        caf_info+                        --      c.f. GHC.Core.Op.Tidy.tidyLetBndr         `setArityInfo`      arity         `setStrictnessInfo` final_sig+        `setCprInfo`        final_cpr         `setUnfoldingInfo`  minimal_unfold_info  -- See note [Preserve evaluatedness]-                                                 -- in CoreTidy+                                                 -- in GHC.Core.Op.Tidy    | otherwise           -- Externally-visible Ids get the whole lot   = vanillaIdInfo-        `setCafInfo`           caf_info         `setArityInfo`         arity         `setStrictnessInfo`    final_sig+        `setCprInfo`           final_cpr         `setOccInfo`           robust_occ_info         `setInlinePragInfo`    (inlinePragInfo idinfo)         `setUnfoldingInfo`     unfold_info@@ -1219,14 +1190,23 @@               | 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 (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+    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 = mkTopUnfolding dflags is_bot tidy_rhs     is_bot = isBottomingSig final_sig@@ -1253,137 +1233,6 @@     -- 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 tidying. 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 numerous other ways in which we can introduce inconsistencies-between CorePrep and GHC.Iface.Tidy. 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 tidying (see Note [Disgusting computation of-CafRefs] in GHC.Iface.Tidy). 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-  {- ************************************************************************
compiler/GHC/Iface/Utils.hs view
@@ -68,10 +68,10 @@ import GHC.CoreToIface import FlagChecker -import DsUsage ( mkUsageInfo, mkUsedNames, mkDependencies )+import GHC.HsToCore.Usage ( mkUsageInfo, mkUsedNames, mkDependencies ) import Id import Annotations-import CoreSyn+import GHC.Core import Class import TyCon import CoAxiom@@ -83,9 +83,9 @@ import FamInstEnv import TcRnMonad import GHC.Hs-import HscTypes-import Finder-import DynFlags+import GHC.Driver.Types+import GHC.Driver.Finder+import GHC.Driver.Session import VarEnv import Var import Name@@ -108,19 +108,19 @@ import Fingerprint import Exception import UniqSet-import Packages-import ExtractDocs+import GHC.Driver.Packages+import GHC.HsToCore.Docs  import Control.Monad import Data.Function-import Data.List+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(..),+import GHC.Driver.Plugins ( PluginRecompile(..), PluginWithArgs(..), LoadedPlugin(..),                  pluginRecompile', plugins )  --Qualified import so we can define a Semigroup instance@@ -160,17 +160,34 @@  -- | Fully instantiate a interface -- Adds fingerprints and potentially code generator produced information.-mkFullIface :: HscEnv -> PartialModIface -> IO ModIface-mkFullIface hsc_env partial_iface = do+mkFullIface :: HscEnv -> PartialModIface -> Maybe NameSet -> IO ModIface+mkFullIface hsc_env partial_iface mb_non_cafs = do+    let decls+          | gopt Opt_OmitInterfacePragmas (hsc_dflags hsc_env)+          = mi_decls partial_iface+          | otherwise+          = updateDeclCafInfos (mi_decls partial_iface) mb_non_cafs+     full_iface <-       {-# SCC "addFingerprints" #-}-      addFingerprints hsc_env partial_iface+      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 +updateDeclCafInfos :: [IfaceDecl] -> Maybe NameSet -> [IfaceDecl]+updateDeclCafInfos decls Nothing = decls+updateDeclCafInfos decls (Just non_cafs) = map update_decl decls+  where+    update_decl decl+      | IfaceId nm ty details infos <- decl+      , elemNameSet nm non_cafs+      = IfaceId nm ty details (HsNoCafRefs : infos)+      | otherwise+      = 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').@@ -221,7 +238,7 @@                    doc_hdr' doc_map arg_map                    mod_details -          mkFullIface hsc_env partial_iface+          mkFullIface hsc_env partial_iface Nothing  mkIface_ :: HscEnv -> Module -> HscSource          -> Bool -> Dependencies -> GlobalRdrEnv@@ -1751,7 +1768,7 @@   = IfaceId { ifName      = getName dataCon,               ifType      = toIfaceType (dataConUserType dataCon),               ifIdDetails = IfVanillaId,-              ifIdInfo    = NoInfo }+              ifIdInfo    = [] }  -------------------------- coAxiomToIfaceDecl :: CoAxiom br -> IfaceDecl
compiler/GHC/IfaceToCore.hs view
@@ -38,15 +38,15 @@ import CoAxiom import TyCoRep    -- needs to build types & coercions in a knot import TyCoSubst ( substTyCoVars )-import HscTypes+import GHC.Driver.Types import Annotations import InstEnv import FamInstEnv-import CoreSyn-import CoreUtils-import CoreUnfold-import CoreLint-import MkCore+import GHC.Core+import GHC.Core.Utils+import GHC.Core.Unfold+import GHC.Core.Lint+import GHC.Core.Make import Id import MkId import IdInfo@@ -70,7 +70,7 @@ import Outputable import Maybes import SrcLoc-import DynFlags+import GHC.Driver.Session import Util import FastString import BasicTypes hiding ( SuccessFlag(..) )@@ -128,14 +128,14 @@     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+    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 HscMain: We are typechecking an+    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.@@ -1249,7 +1249,6 @@     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@@ -1465,16 +1464,26 @@     -- 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++    let needed = needed_prags info+    foldlM tcPrag init_info needed   where+    needed_prags :: [IfaceInfoItem] -> [IfaceInfoItem]+    needed_prags items+      | not ignore_prags = items+      | otherwise        = filter need_prag items++    need_prag :: IfaceInfoItem -> Bool+      -- compulsory unfoldings are really compulsory.+      -- See wrinkle in Note [Wiring in unsafeCoerce#] in Desugar+    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) @@ -1492,7 +1501,7 @@ 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+        ; mb_expr <- tcPragExpr False toplvl name if_expr         ; let unf_src | stable    = InlineStable                       | otherwise = InlineRhs         ; return $ case mb_expr of@@ -1506,13 +1515,13 @@      -- Strictness should occur before unfolding!     strict_sig = strictnessInfo info tcUnfolding toplvl name _ _ (IfCompulsory if_expr)-  = do  { mb_expr <- tcPragExpr toplvl name 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 toplvl name 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 )}@@ -1534,17 +1543,20 @@ an unfolding that isn't going to be looked at. -} -tcPragExpr :: TopLevelFlag -> Name -> IfaceExpr -> IfL (Maybe CoreExpr)-tcPragExpr toplvl name expr+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+    when (isTopLevel toplvl) $+      whenGOptM Opt_DoCoreLinting $ do         in_scope <- get_in_scope         dflags   <- getDynFlags-        case lintUnfolding dflags noSrcLoc in_scope core_expr' of+        case lintUnfolding is_compulsory dflags noSrcLoc in_scope core_expr' of           Nothing       -> return ()           Just fail_msg -> do { mod <- getIfModule                               ; pprPanic "Iface Lint failure"@@ -1554,7 +1566,8 @@                                         , text "Iface expr =" <+> ppr expr ]) }     return core_expr'   where-    doc = text "Unfolding of" <+> ppr name+    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@@ -1685,7 +1698,7 @@   = do { thing <- tcIfaceGlobal name        ; return $ case ifaceTyConIsPromoted info of            NotPromoted -> tyThingTyCon thing-           IsPromoted    -> promoteDataCon $ tyThingDataCon thing }+           IsPromoted  -> promoteDataCon $ tyThingDataCon thing }  tcIfaceCoAxiom :: Name -> IfL (CoAxiom Branched) tcIfaceCoAxiom name = do { thing <- tcIfaceImplicit name
compiler/GHC/IfaceToCore.hs-boot view
@@ -1,16 +1,15 @@ module GHC.IfaceToCore where  import GhcPrelude-import GHC.Iface.Syntax-   ( 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 )+import GHC.Iface.Syntax ( IfaceDecl, IfaceClsInst, IfaceFamInst, IfaceRule+                        , IfaceAnnotation, IfaceCompleteMatch )+import TyCoRep          ( TyThing )+import TcRnTypes        ( IfL )+import InstEnv          ( ClsInst )+import FamInstEnv       ( FamInst )+import GHC.Core         ( CoreRule )+import GHC.Driver.Types ( CompleteMatch )+import Annotations      ( Annotation )  tcIfaceDecl         :: Bool -> IfaceDecl -> IfL TyThing tcIfaceRules        :: Bool -> [IfaceRule] -> IfL [CoreRule]
+ compiler/GHC/Llvm.hs view
@@ -0,0 +1,64 @@+-- ----------------------------------------------------------------------------+-- | This module supplies bindings to generate Llvm IR from Haskell+-- (<http://www.llvm.org/docs/LangRef.html>).+--+-- 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 (<http://www.cs.uu.nl/wiki/Ehc/WebHome>).+--++module GHC.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 GHC.Llvm.Syntax+import GHC.Llvm.MetaData+import GHC.Llvm.Ppr+import GHC.Llvm.Types+
+ compiler/GHC/Llvm/MetaData.hs view
@@ -0,0 +1,95 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++module GHC.Llvm.MetaData where++import GhcPrelude++import GHC.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 = !{ [<metadata expressions>] !}+--+-- * 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 = !{ [!<n>] }' form).+    = MetaNamed !LMString [MetaId]+    -- | Metadata node declaration.+    -- ('!0 = metadata !{ <metadata expression> }' form).+    | MetaUnnamed !MetaId !MetaExpr
+ compiler/GHC/Llvm/Ppr.hs view
@@ -0,0 +1,498 @@+{-# LANGUAGE CPP #-}++--------------------------------------------------------------------------------+-- | 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,++    ) where++#include "HsVersions.h"++import GhcPrelude++import GHC.Llvm.Syntax+import GHC.Llvm.MetaData+import GHC.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) = pprPanic "ppLlvmGlobal" $+  text "Non Global var ppr as global! " <> ppr var <> text "=" <> 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 = hsep $ punctuate comma $ map ppCallMetaExpr 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++        -- Metadata needs to be marked as having the `metadata` type when used+        -- in a call argument+        ppCallMetaExpr (MetaVar v) = ppr 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 '!'
+ compiler/GHC/Llvm/Syntax.hs view
@@ -0,0 +1,352 @@+--------------------------------------------------------------------------------+-- | The LLVM abstract syntax.+--++module GHC.Llvm.Syntax where++import GhcPrelude++import GHC.Llvm.MetaData+import GHC.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)+
+ compiler/GHC/Llvm/Types.hs view
@@ -0,0 +1,887 @@+{-# LANGUAGE CPP, GeneralizedNewtypeDeriving #-}++--------------------------------------------------------------------------------+-- | The LLVM Type System.+--++module GHC.Llvm.Types where++#include "HsVersions.h"++import GhcPrelude++import Data.Char+import Data.Int+import Numeric++import GHC.Driver.Session+import FastString+import Outputable+import 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 (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 (LMLitVar x)  = ppr x+  ppr (x         )  = ppr (getVarType x) <+> 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 l@(LMVectorLit {}) = ppLit l+  ppr l                  = ppr (getLitType l) <+> 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 pprPanic "pprStaticArith" $+            text op_name <> text " with different types! s1: " <> ppr s1+                         <> text", s2: " <> 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 _ _)       = pprPanic "ppLit" (text "Can't print this float literal: " <> 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 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"+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 <http://llvm.org/docs/LangRef.html#fnattrs>+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 <http://www.llvm.org/docs/LangRef.html#linkage>, 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)
+ compiler/GHC/Plugins.hs view
@@ -0,0 +1,132 @@+{-# 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 "CoreMonad".+module GHC.Plugins(+        module GHC.Driver.Plugins,+        module RdrName, module OccName, module Name, module Var, module Id, module IdInfo,+        module CoreMonad, module GHC.Core, module Literal, module DataCon,+        module GHC.Core.Utils, module GHC.Core.Make, module GHC.Core.FVs,+        module GHC.Core.Subst, module GHC.Core.Rules, module Annotations,+        module GHC.Driver.Session, module GHC.Driver.Packages,+        module Module, module Type, module TyCon, module Coercion,+        module TysWiredIn, module GHC.Driver.Types, 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 GHC.Driver.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 GHC.Core+import Literal+import 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 Annotations++-- Pipeline-related stuff+import GHC.Driver.Session+import GHC.Driver.Packages++-- Important GHC types+import Module+import Type     hiding {- conflict with GHC.Core.Subst -}+                ( substTy, extendTvSubst, extendTvSubstList, isInScope )+import Coercion hiding {- conflict with GHC.Core.Subst -}+                ( substCo )+import TyCon+import TysWiredIn+import GHC.Driver.Types+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 GHC.Iface.Env    ( 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
compiler/GHC/Rename/Binds.hs view
@@ -44,7 +44,7 @@                         , checkDupRdrNames, warnUnusedLocalBinds                         , checkUnusedRecordWildcard                         , checkDupAndShadowedNames, bindLocalNamesFV )-import DynFlags+import GHC.Driver.Session import Module import Name import NameEnv@@ -64,7 +64,7 @@  import Control.Monad import Data.Foldable      ( toList )-import Data.List          ( partition, sort )+import Data.List          ( partition, sortBy ) import Data.List.NonEmpty ( NonEmpty(..) )  {-@@ -1162,7 +1162,7 @@ ************************************************************************ -} -rnMatchGroup :: Outputable (body GhcPs) => HsMatchContext Name+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)@@ -1173,13 +1173,13 @@        ; return (mkMatchGroup origin new_ms, ms_fvs) } rnMatchGroup _ _ (XMatchGroup nec) = noExtCon nec -rnMatch :: Outputable (body GhcPs) => HsMatchContext Name+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 Name+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)@@ -1195,7 +1195,7 @@                         , m_grhss = grhss'}, grhss_fvs ) }} rnMatch' _ _ (XMatch nec) = noExtCon nec -emptyCaseErr :: HsMatchContext Name -> SDoc+emptyCaseErr :: HsMatchContext GhcRn -> SDoc emptyCaseErr ctxt = hang (text "Empty list of alternatives in" <+> pp_ctxt)                        2 (text "Use EmptyCase to allow this")   where@@ -1212,7 +1212,7 @@ ************************************************************************ -} -rnGRHSs :: HsMatchContext Name+rnGRHSs :: HsMatchContext GhcRn         -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars))         -> GRHSs GhcPs (Located (body GhcPs))         -> RnM (GRHSs GhcRn (Located (body GhcRn)), FreeVars)@@ -1222,13 +1222,13 @@     return (GRHSs noExtField grhss' (L l binds'), fvGRHSs) rnGRHSs _ _ (XGRHSs nec) = noExtCon nec -rnGRHS :: HsMatchContext Name+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 Name+rnGRHS' :: HsMatchContext GhcRn         -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars))         -> GRHS GhcPs (Located (body GhcPs))         -> RnM (GRHS GhcRn (Located (body GhcRn)), FreeVars)@@ -1296,7 +1296,7 @@   = addErrAt loc $     vcat [ text "Duplicate" <+> what_it_is            <> text "s for" <+> quotes (ppr name)-         , text "at" <+> vcat (map ppr $ sort+         , text "at" <+> vcat (map ppr $ sortBy SrcLoc.leftmost_smallest                                        $ map (getLoc . fst)                                        $ toList pairs)          ]@@ -1332,6 +1332,6 @@ dupMinimalSigErr sigs@(L loc _ : _)   = addErrAt loc $     vcat [ text "Multiple minimal complete definitions"-         , text "at" <+> vcat (map ppr $ sort $ map getLoc sigs)+         , text "at" <+> vcat (map ppr $ sortBy SrcLoc.leftmost_smallest $ map getLoc sigs)          , text "Combine alternative minimal complete definitions with `|'" ] dupMinimalSigErr [] = panic "dupMinimalSigErr"
compiler/GHC/Rename/Env.hs view
@@ -30,7 +30,7 @@         lookupGreAvailRn,          -- Rebindable Syntax-        lookupSyntaxName, lookupSyntaxName', lookupSyntaxNames,+        lookupSyntax, lookupSyntaxExpr, lookupSyntaxName, lookupSyntaxNames,         lookupIfThenElse,          -- Constructing usage information@@ -50,7 +50,7 @@ import GHC.Iface.Env import GHC.Hs import RdrName-import HscTypes+import GHC.Driver.Types import TcEnv import TcRnMonad import RdrHsSyn         ( filterCTuple, setRdrNameSpace )@@ -65,13 +65,13 @@ import TyCon import ErrUtils         ( MsgDoc ) import PrelNames        ( rOOT_MAIN )-import BasicTypes       ( pprWarningTxtForMsg, TopLevelFlag(..))+import BasicTypes       ( pprWarningTxtForMsg, TopLevelFlag(..), TupleSort(..) ) import SrcLoc import Outputable import UniqSet          ( uniqSetAny ) import Util import Maybes-import DynFlags+import GHC.Driver.Session import FastString import Control.Monad import ListSetOps       ( minusList )@@ -80,7 +80,9 @@ import GHC.Rename.Utils import qualified Data.Semigroup as Semi import Data.Either      ( partitionEithers )-import Data.List        (find)+import Data.List        ( find, sortBy )+import Control.Arrow    ( first )+import Data.Function  {- *********************************************************@@ -297,8 +299,13 @@                     ATyCon tc                 -> Just tc                     AConLike (RealDataCon dc) -> Just (dataConTyCon dc)                     _                         -> Nothing-  , isTupleTyCon tycon-  = do { checkTupSize (tyConArity tycon)+  , 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@@ -343,7 +350,7 @@   = 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)+    sorted_names = sortBy (SrcLoc.leftmost_smallest `on` nameSrcSpan) (map gre_name gres)     pp_one name       = hang (pprNameSpace (occNameSpace (getOccName name))               <+> quotes (ppr name) <> comma)@@ -1056,6 +1063,9 @@ -- 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@@ -1625,45 +1635,46 @@   * 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.+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 :: RnM (Maybe (SyntaxExpr GhcRn), FreeVars)--- Different to lookupSyntaxName because in the non-rebindable+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+lookupIfThenElse maybe_use_rs   = do { rebindable_on <- xoptM LangExt.RebindableSyntax-       ; if not rebindable_on-         then return (Nothing, emptyFVs)+       ; if not (rebindable_on && maybe_use_rs)+         then return (NoSyntaxExprRn, emptyFVs)          else do { ite <- lookupOccRn (mkVarUnqual (fsLit "ifThenElse"))-                 ; return ( Just (mkRnSyntaxExpr ite)+                 ; return ( 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 :: 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 (mkRnSyntaxExpr std_name, emptyFVs)+           return (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) } }+              ; 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
compiler/GHC/Rename/Expr.hs view
@@ -44,7 +44,7 @@ import GHC.Rename.Splice  ( rnBracket, rnSpliceExpr, checkThLocalName ) import GHC.Rename.Types import GHC.Rename.Pat-import DynFlags+import GHC.Driver.Session import PrelNames  import BasicTypes@@ -202,7 +202,7 @@  rnExpr (NegApp _ e _)   = do { (e', fv_e)         <- rnLExpr e-       ; (neg_name, fv_neg) <- lookupSyntaxName negateName+       ; (neg_name, fv_neg) <- lookupSyntax negateName        ; final_e            <- mkNegAppRn e' neg_name        ; return (final_e, fv_e `plusFV` fv_neg) } @@ -273,7 +273,7 @@         ; (exps', fvs) <- rnExprs exps         ; if opt_OverloadedLists            then do {-            ; (from_list_n_name, fvs') <- lookupSyntaxName fromListNName+            ; (from_list_n_name, fvs') <- lookupSyntax fromListNName             ; return (ExplicitList x (Just from_list_n_name) exps'                      , fvs `plusFV` fvs') }            else@@ -322,12 +322,12 @@                              rnLExpr expr         ; return (ExprWithTySig noExtField expr' pty', fvExpr `plusFV` fvTy) } -rnExpr (HsIf x _ p b1 b2)+rnExpr (HsIf might_use_rebindable_syntax _ 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]) }+       ; (mb_ite, fvITE) <- lookupIfThenElse might_use_rebindable_syntax+       ; return (HsIf noExtField mb_ite p' b1' b2', plusFVs [fvITE, fvP, fvB1, fvB2]) }  rnExpr (HsMultiIf x alts)   = do { (alts', fvs) <- mapFvRn (rnGRHS IfAlt rnLExpr) alts@@ -339,7 +339,7 @@        ; (new_seq, fvs) <- rnArithSeq seq        ; if opt_OverloadedLists            then do {-            ; (from_list_name, fvs') <- lookupSyntaxName fromListName+            ; (from_list_name, fvs') <- lookupSyntax fromListName             ; return (ArithSeq x (Just from_list_name) new_seq                      , fvs `plusFV` fvs') }            else@@ -501,7 +501,7 @@   = do { (p', fvP) <- rnLExpr p        ; (b1', fvB1) <- rnLCmd b1        ; (b2', fvB2) <- rnLCmd b2-       ; (mb_ite, fvITE) <- lookupIfThenElse+       ; (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)@@ -514,7 +514,6 @@             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  ---------------------------------------------------@@ -532,7 +531,6 @@ methodNamesCmd (HsCmdArrApp _ _arrow _arg HsHigherOrderApp _rtl)   = unitFV appAName methodNamesCmd (HsCmdArrForm {}) = emptyFVs-methodNamesCmd (HsCmdWrap _ _ cmd) = methodNamesCmd cmd  methodNamesCmd (HsCmdPar _ c) = methodNamesLCmd c @@ -658,7 +656,7 @@  -- | Rename some Stmts rnStmts :: Outputable (body GhcPs)-        => HsStmtContext Name+        => 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))]@@ -672,10 +670,10 @@ -- | like 'rnStmts' but applies a post-processing step to the renamed Stmts rnStmtsWithPostProcessing         :: Outputable (body GhcPs)-        => HsStmtContext Name+        => HsStmtContext GhcRn         -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars))            -- ^ How to rename the body of each statement (e.g. rnLExpr)-        -> (HsStmtContext Name+        -> (HsStmtContext GhcRn               -> [(LStmt GhcRn (Located (body GhcRn)), FreeVars)]               -> RnM ([LStmt GhcRn (Located (body GhcRn))], FreeVars))            -- ^ postprocess the statements@@ -694,7 +692,7 @@  -- | maybe rearrange statements according to the ApplicativeDo transformation postProcessStmtsForApplicativeDo-  :: HsStmtContext Name+  :: HsStmtContext GhcRn   -> [(ExprLStmt GhcRn, FreeVars)]   -> RnM ([ExprLStmt GhcRn], FreeVars) postProcessStmtsForApplicativeDo ctxt stmts@@ -706,7 +704,7 @@        ; let is_do_expr | DoExpr <- ctxt = True                         | otherwise = False        -- don't apply the transformation inside TH brackets, because-       -- DsMeta does not handle ApplicativeDo.+       -- 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)@@ -715,14 +713,14 @@  -- | strip the FreeVars annotations from statements noPostProcessStmts-  :: HsStmtContext Name+  :: 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 Name+        => HsStmtContext GhcRn         -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars))         -> [LStmt GhcPs (Located (body GhcPs))]         -> ([Name] -> RnM (thing, FreeVars))@@ -785,7 +783,7 @@ -}  rnStmt :: Outputable (body GhcPs)-       => HsStmtContext Name+       => HsStmtContext GhcRn        -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars))           -- ^ How to rename the body of the statement        -> LStmt GhcPs (Located (body GhcPs))@@ -928,7 +926,7 @@ rnStmt _ _ (L _ (XStmtLR nec)) _ =   noExtCon nec -rnParallelStmts :: forall thing. HsStmtContext Name+rnParallelStmts :: forall thing. HsStmtContext GhcRn                 -> SyntaxExpr GhcRn                 -> [ParStmtBlock GhcPs GhcPs]                 -> ([Name] -> RnM (thing, FreeVars))@@ -963,15 +961,15 @@     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 :: HsStmtContext GhcRn -> Name -> RnM (SyntaxExpr GhcRn, FreeVars)+-- Like lookupSyntax, but respects contexts lookupStmtName ctxt n   | rebindableContext ctxt-  = lookupSyntaxName n+  = lookupSyntax n   | otherwise   = return (mkRnSyntaxExpr n, emptyFVs) -lookupStmtNamePoly :: HsStmtContext Name -> Name -> RnM (HsExpr GhcRn, FreeVars)+lookupStmtNamePoly :: HsStmtContext GhcRn -> Name -> RnM (HsExpr GhcRn, FreeVars) lookupStmtNamePoly ctxt name   | rebindableContext ctxt   = do { rebindable_on <- xoptM LangExt.RebindableSyntax@@ -986,8 +984,8 @@  -- | 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+-- 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@@ -1156,19 +1154,19 @@         -- 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+        ; (ret_op, fvs1)   <- lookupSyntax 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+       ; (then_op, fvs1) <- lookupSyntax 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+       ; (bind_op, fvs1) <- lookupSyntax bindMName         ; (fail_op, fvs2) <- getMonadFailOp @@ -1219,7 +1217,7 @@        ; return (concat segs_s) }  ----------------------------------------------segmentRecStmts :: SrcSpan -> HsStmtContext Name+segmentRecStmts :: SrcSpan -> HsStmtContext GhcRn                 -> Stmt GhcRn body                 -> [Segment (LStmt GhcRn body)] -> FreeVars                 -> ([LStmt GhcRn body], FreeVars)@@ -1323,7 +1321,7 @@        r <- x } -} -glomSegments :: HsStmtContext Name+glomSegments :: HsStmtContext GhcRn              -> [Segment (LStmt GhcRn body)]              -> [Segment [LStmt GhcRn body]]                                   -- Each segment has a non-empty list of Stmts@@ -1513,7 +1511,7 @@  * Desugarer: Any do-block which contains applicative statements is desugared   as outlined above, to use the Applicative combinators.-  Relevant module: DsExpr+  Relevant module: GHC.HsToCore.Expr  -} @@ -1534,7 +1532,7 @@ -- | rearrange a list of statements using ApplicativeDoStmt.  See -- Note [ApplicativeDo]. rearrangeForApplicativeDo-  :: HsStmtContext Name+  :: HsStmtContext GhcRn   -> [(ExprLStmt GhcRn, FreeVars)]   -> RnM ([ExprLStmt GhcRn], FreeVars) @@ -1545,8 +1543,8 @@   let stmt_tree | optimal_ado = mkStmtTreeOptimal stmts                 | otherwise = mkStmtTreeHeuristic stmts   traceRn "rearrangeForADo" (ppr stmt_tree)-  return_name <- lookupSyntaxName' returnMName-  pure_name   <- lookupSyntaxName' pureAName+  (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@@ -1660,7 +1658,7 @@ -- ApplicativeStmt where necessary. stmtTreeToStmts   :: MonadNames-  -> HsStmtContext Name+  -> HsStmtContext GhcRn   -> ExprStmtTree   -> [ExprLStmt GhcRn]             -- ^ the "tail"   -> FreeVars                     -- ^ free variables of the tail@@ -1744,8 +1742,8 @@         if | L _ ApplicativeStmt{} <- last stmts' ->              return (unLoc tup, emptyNameSet)            | otherwise -> do-             ret <- lookupSyntaxName' returnMName-             let expr = HsApp noExtField (noLoc (HsVar noExtField (noLoc ret))) tup+             (ret, _) <- lookupSyntaxExpr returnMName+             let expr = HsApp noExtField (noLoc ret) tup              return (expr, emptyFVs)      return ( ApplicativeArgMany               { xarg_app_arg_many = noExtField@@ -1931,7 +1929,7 @@ -- 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+  :: HsStmtContext GhcRn   -> [ApplicativeArg GhcRn]             -- ^ The args   -> Bool                               -- ^ True <=> need a join   -> [ExprLStmt GhcRn]        -- ^ The body statements@@ -1991,7 +1989,7 @@ ************************************************************************ -} -checkEmptyStmts :: HsStmtContext Name -> RnM ()+checkEmptyStmts :: HsStmtContext GhcRn -> RnM () -- We've seen an empty sequence of Stmts... is that ok? checkEmptyStmts ctxt   = unless (okEmpty ctxt) (addErr (emptyErr ctxt))@@ -2000,13 +1998,13 @@ okEmpty (PatGuard {}) = True okEmpty _             = False -emptyErr :: HsStmtContext Name -> SDoc+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 Name+checkLastStmt :: Outputable (body GhcPs) => HsStmtContext GhcRn               -> LStmt GhcPs (Located (body GhcPs))               -> RnM (LStmt GhcPs (Located (body GhcPs))) checkLastStmt ctxt lstmt@(L loc stmt)@@ -2036,7 +2034,7 @@       = do { checkStmt ctxt lstmt; return lstmt }  -- Checking when a particular Stmt is ok-checkStmt :: HsStmtContext Name+checkStmt :: HsStmtContext GhcRn           -> LStmt GhcPs (Located (body GhcPs))           -> RnM () checkStmt ctxt (L _ stmt)@@ -2064,7 +2062,7 @@ emptyInvalid = NotValid Outputable.empty  okStmt, okDoStmt, okCompStmt, okParStmt-   :: DynFlags -> HsStmtContext Name+   :: 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@@ -2147,7 +2145,7 @@ ---------  monadFailOp :: LPat GhcPs-            -> HsStmtContext Name+            -> HsStmtContext GhcRn             -> RnM (SyntaxExpr GhcRn, FreeVars) monadFailOp pat ctxt   -- If the pattern is irrefutable (e.g.: wildcard, tuple, ~pat, etc.)@@ -2194,18 +2192,17 @@   where     reallyGetMonadFailOp rebindableSyntax overloadedStrings       | rebindableSyntax && overloadedStrings = do-        (failExpr, failFvs) <- lookupSyntaxName failMName-        (fromStringExpr, fromStringFvs) <- lookupSyntaxName fromStringName+        (failExpr, failFvs) <- lookupSyntaxExpr failMName+        (fromStringExpr, fromStringFvs) <- lookupSyntaxExpr fromStringName         let arg_lit = mkVarOcc "arg"         arg_name <- newSysName arg_lit-        let arg_syn_expr = mkRnSyntaxExpr arg_name+        let arg_syn_expr = nlHsVar arg_name             body :: LHsExpr GhcRn =-              nlHsApp (noLoc $ syn_expr failExpr)-                      (nlHsApp (noLoc $ syn_expr fromStringExpr)-                                (noLoc $ syn_expr arg_syn_expr))+              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 = lookupSyntaxName failMName+      | otherwise = lookupSyntax failMName
compiler/GHC/Rename/Expr.hs-boot view
@@ -10,7 +10,7 @@         -> RnM (LHsExpr GhcRn, FreeVars)  rnStmts :: --forall thing body.-           Outputable (body GhcPs) => HsStmtContext Name+           Outputable (body GhcPs) => HsStmtContext GhcRn         -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars))         -> [LStmt GhcPs (Located (body GhcPs))]         -> ([Name] -> RnM (thing, FreeVars))
compiler/GHC/Rename/Fixity.hs view
@@ -21,7 +21,7 @@ import GHC.Iface.Load import GHC.Hs import RdrName-import HscTypes+import GHC.Driver.Types import TcRnMonad import Name import NameEnv
compiler/GHC/Rename/Names.hs view
@@ -34,7 +34,7 @@  import GhcPrelude -import DynFlags+import GHC.Driver.Session import TyCoPpr import GHC.Hs import TcEnv@@ -50,7 +50,7 @@ import NameSet import Avail import FieldLabel-import HscTypes+import GHC.Driver.Types import RdrName import RdrHsSyn        ( setRdrNameSpace ) import Outputable@@ -71,6 +71,7 @@ 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  ((</>)) @@ -86,7 +87,7 @@ 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]+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@@ -111,7 +112,7 @@ 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.+GHC.Driver.Main.checkSafeImports.  See the note below, [Trust Own Package] for a corner case in this method and how its handled.@@ -380,6 +381,9 @@           _           -> 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 }) @@ -487,6 +491,40 @@      }  +-- | 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"@@ -506,7 +544,7 @@  Note [Top-level Names in Template Haskell decl quotes] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-See also: Note [Interactively-bound Ids in GHCi] in HscTypes+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:@@ -1358,7 +1396,7 @@     unused_decl decl@(L loc (ImportDecl { ideclHiding = imps }))       = (decl, used_gres, nameSetElemsStable unused_imps)       where-        used_gres = Map.lookup (srcSpanEnd loc) import_usage+        used_gres = lookupSrcLoc (srcSpanEnd loc) import_usage                                -- srcSpanEnd: see Note [The ImportMap]                     `orElse` [] @@ -1422,7 +1460,7 @@ The [GlobalRdrElt] are the things imported from that decl. -} -type ImportMap = Map SrcLoc [GlobalRdrElt]  -- See [The ImportMap]+type ImportMap = Map RealSrcLoc [GlobalRdrElt]  -- See [The ImportMap]      -- If loc :-> gres, then      --   'loc' = the end loc of the bestImport of each GRE in 'gres' @@ -1433,12 +1471,13 @@ 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+    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-          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)@@ -1743,7 +1782,9 @@                    vcat (map (ppr . nameSrcLoc) sorted_names)]   where     name = gre_name gre-    sorted_names = sortWith nameSrcLoc (map gre_name gres)+    sorted_names =+      sortBy (SrcLoc.leftmost_smallest `on` nameSrcSpan)+             (map gre_name gres)
compiler/GHC/Rename/Pat.hs view
@@ -309,7 +309,7 @@ --   * local namemaker --   * unused and duplicate checking --   * no fixities-rnPats :: HsMatchContext Name -- for error messages+rnPats :: HsMatchContext GhcRn -- for error messages        -> [LPat GhcPs]        -> ([LPat GhcRn] -> RnM (a, FreeVars))        -> RnM (a, FreeVars)@@ -337,7 +337,7 @@   where     doc_pat = text "In" <+> pprMatchContext ctxt -rnPat :: HsMatchContext Name -- for error messages+rnPat :: HsMatchContext GhcRn -- for error messages       -> LPat GhcPs       -> (LPat GhcRn -> RnM (a, FreeVars))       -> RnM (a, FreeVars)     -- Variables bound by pattern do not@@ -429,7 +429,7 @@ 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) <- lookupSyntaxName negateName+           <- let negative = do { (neg, fvs) <- lookupSyntax negateName                                 ; return (Just neg, fvs) }                   positive = return (Nothing, emptyFVs)               in liftCpsFV $ case (mb_neg , mb_neg') of@@ -437,7 +437,7 @@                                   (Just _ , Nothing) -> negative                                   (Nothing, Nothing) -> positive                                   (Just _ , Just _ ) -> positive-       ; eq' <- liftCpsFV $ lookupSyntaxName eqName+       ; eq' <- liftCpsFV $ lookupSyntax eqName        ; return (NPat x (L l lit') mb_neg' eq') }  rnPatAndThen mk (NPlusKPat x rdr (L l lit) _ _ _ )@@ -446,8 +446,8 @@                                                 -- We skip negateName as                                                 -- negative zero doesn't make                                                 -- sense in n + k patterns-       ; minus <- liftCpsFV $ lookupSyntaxName minusName-       ; ge    <- liftCpsFV $ lookupSyntaxName geName+       ; 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@@ -481,7 +481,7 @@   = do { opt_OverloadedLists <- liftCps $ xoptM LangExt.OverloadedLists        ; pats' <- rnLPatsAndThen mk pats        ; case opt_OverloadedLists of-          True -> do { (to_list_name,_) <- liftCps $ lookupSyntaxName toListName+          True -> do { (to_list_name,_) <- liftCps $ lookupSyntax toListName                      ; return (ListPat (Just to_list_name) pats')}           False -> return (ListPat Nothing pats') } @@ -864,16 +864,12 @@             | 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+        ; (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 { (SyntaxExpr { syn_expr = negate_name }, fvs2)-                      <- lookupSyntaxName negateName+          then do { (negate_name, fvs2) <- lookupSyntaxExpr negateName                   ; return ((lit' { ol_val = negateOverLitVal val }, Just negate_name)                                   , fvs1 `plusFV` fvs2) }           else return ((lit', Nothing), fvs1) }
compiler/GHC/Rename/Source.hs view
@@ -43,7 +43,7 @@  import ForeignCall      ( CCallTarget(..) ) import Module-import HscTypes         ( Warnings(..), plusWarns )+import GHC.Driver.Types         ( Warnings(..), plusWarns ) import PrelNames        ( applicativeClassName, pureAName, thenAName                         , monadClassName, returnMName, thenMName                         , semigroupClassName, sappendName@@ -58,9 +58,9 @@ import BasicTypes       ( pprRuleName, TypeOrKind(..) ) import FastString import SrcLoc-import DynFlags+import GHC.Driver.Session import Util             ( debugIsOn, filterOut, lengthExceeds, partitionWith )-import HscTypes         ( HscEnv, hsc_dflags )+import GHC.Driver.Types         ( HscEnv, hsc_dflags ) import ListSetOps       ( findDupsEq, removeDups, equivClasses ) import Digraph          ( SCC, flattenSCC, flattenSCCs, Node(..)                         , stronglyConnCompFromEdgedVerticesUniq )@@ -1475,13 +1475,13 @@           quotes (ppr $ roleAnnotDeclName first_decl) <> colon)        2 (vcat $ map pp_role_annot $ NE.toList sorted_list)     where-      sorted_list = NE.sortBy cmp_annot list+      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_annot (L loc1 _) (L loc2 _) = loc1 `compare` loc2+      cmp_loc = SrcLoc.leftmost_smallest `on` getLoc  dupKindSig_Err :: NonEmpty (LStandaloneKindSig GhcPs) -> RnM () dupKindSig_Err list@@ -1496,7 +1496,7 @@       pp_kisig (L loc decl) =         hang (ppr decl) 4 (text "-- written at" <+> ppr loc) -      cmp_loc (L loc1 _) (L loc2 _) = loc1 `compare` loc2+      cmp_loc = SrcLoc.leftmost_smallest `on` getLoc  {- Note [Role annotations in the renamer] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
compiler/GHC/Rename/Splice.hs view
@@ -40,11 +40,11 @@ import TcEnv            ( checkWellStaged ) import THNames          ( liftName ) -import DynFlags+import GHC.Driver.Session import FastString import ErrUtils         ( dumpIfSet_dyn_printer, DumpFormat (..) ) import TcEnv            ( tcMetaTy )-import Hooks+import GHC.Driver.Hooks import THNames          ( quoteExpName, quotePatName, quoteDecName, quoteTypeName                         , decsQTyConName, expQTyConName, patQTyConName, typeQTyConName, ) @@ -270,9 +270,10 @@                 ; writeMutVar ps_var (pending_splice : ps)                 ; return (result, fvs) } -        _ ->  do { (splice', fvs1) <- checkNoErrs $-                                      setStage (Splice splice_type) $-                                      rnSplice splice+        _ ->  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@@ -284,6 +285,23 @@                    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)+     spliceExtension (XSplice nec) = noExtCon nec+ ------------------  -- | Returns the result of running a splice and the modFinalizers collected@@ -304,7 +322,6 @@                 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@@ -352,8 +369,6 @@   = pprPanic "makePending" (ppr splice) makePending _ splice@(HsSpliced {})   = pprPanic "makePending" (ppr splice)-makePending _ splice@(HsSplicedT {})-  = pprPanic "makePending" (ppr splice) makePending _ (XSplice nec)   = noExtCon nec @@ -405,7 +420,6 @@                                                              , unitFV quoter') }  rnSplice splice@(HsSpliced {}) = pprPanic "rnSplice" (ppr splice)-rnSplice splice@(HsSplicedT {}) = pprPanic "rnSplice" (ppr splice) rnSplice        (XSplice nec)   = noExtCon nec  ---------------------@@ -644,7 +658,8 @@ rnTopSpliceDecls :: HsSplice GhcPs -> RnM ([LHsDecl GhcPs], FreeVars) -- Declaration splice at the very top level of the module rnTopSpliceDecls splice-   = do  { (rn_splice, fvs) <- checkNoErrs $+   =  do { checkTopSpliceAllowed splice+         ; (rn_splice, fvs) <- checkNoErrs $                                setStage (Splice Untyped) $                                rnSplice splice            -- As always, be sure to checkNoErrs above lest we end up with@@ -716,8 +731,7 @@              HsTypedSplice   {} -> text "typed splice:"              HsQuasiQuote    {} -> text "quasi-quotation:"              HsSpliced       {} -> text "spliced expression:"-             HsSplicedT      {} -> text "spliced expression:"-             XSplice         {} -> text "spliced expression:"+             XSplice         nec -> noExtCon nec  -- | The splice data to be logged data SpliceInfo
compiler/GHC/Rename/Types.hs view
@@ -36,7 +36,7 @@  import {-# SOURCE #-} GHC.Rename.Splice( rnSpliceType ) -import DynFlags+import GHC.Driver.Session import GHC.Hs import GHC.Rename.Doc    ( rnLHsDoc, rnMbLHsDoc ) import GHC.Rename.Env@@ -349,25 +349,6 @@ {- 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] ~~~~~~~~~~~~~~~~~~~~~~
compiler/GHC/Rename/Unbound.hs view
@@ -20,7 +20,7 @@ import GhcPrelude  import RdrName-import HscTypes+import GHC.Driver.Types import TcRnMonad import Name import Module@@ -29,7 +29,7 @@ import PrelNames ( mkUnboundName, isUnboundName, getUnique) import Util import Maybes-import DynFlags+import GHC.Driver.Session import FastString import Data.List import Data.Function ( on )@@ -133,7 +133,7 @@     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))+                     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)) @@ -310,10 +310,13 @@   -- 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+  pick = listToMaybe . sortBy cmp . 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)+          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
compiler/GHC/Rename/Utils.hs view
@@ -37,7 +37,7 @@  import GHC.Hs import RdrName-import HscTypes+import GHC.Driver.Types import TcEnv import TcRnMonad import Name@@ -49,7 +49,7 @@ import Util import BasicTypes       ( TopLevelFlag(..) ) import ListSetOps       ( removeDups )-import DynFlags+import GHC.Driver.Session import FastString import Control.Monad import Data.List@@ -426,7 +426,7 @@   where     locs      = map get_loc (NE.toList names)     big_loc   = foldr1 combineSrcSpans locs-    locations = text "Bound at:" <+> vcat (map ppr (sort locs))+    locations = text "Bound at:" <+> vcat (map ppr (sortBy SrcLoc.leftmost_smallest locs))  badQualBndrErr :: RdrName -> SDoc badQualBndrErr rdr_name
+ compiler/GHC/Runtime/Debugger.hs view
@@ -0,0 +1,237 @@+{-# 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 GhcPrelude++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 Id+import GHC.Iface.Syntax ( showToHeader )+import GHC.Iface.Env    ( newInteractiveBinder )+import Name+import Var hiding ( varName )+import VarSet+import UniqSet+import Type+import GHC+import Outputable+import GHC.Core.Ppr.TyThing+import ErrUtils+import MonadUtils+import GHC.Driver.Session+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"+                                 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+         `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
+ compiler/GHC/Runtime/Eval.hs view
@@ -0,0 +1,1276 @@+{-# 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 GhcPrelude++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 InstEnv+import GHC.Iface.Env   ( newInteractiveBinder )+import FamInstEnv      ( FamInst )+import GHC.Core.FVs    ( orphNamesOfFamInst )+import TyCon+import Type             hiding( typeKind )+import GHC.Types.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 GHC.ByteCode.Types+import GHC.Runtime.Linker as Linker+import GHC.Driver.Session+import Unique+import UniqSupply+import MonadUtils+import Module+import PrelNames  ( toDynName, pretendNameIsInScope )+import TysWiredIn ( isCTupleTyConName )+import Panic+import Maybes+import ErrUtils+import SrcLoc+import GHC.Runtime.Heap.Inspect+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 Data.Array+import Exception+import Unsafe.Coerce ( unsafeCoerce )++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 = "<interactive>"+  , 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 "<interactive>" 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++      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)++#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 "<unknown>")+   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, "<exception thrown>")++-- 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"+                   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 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 "<interactive>") 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++  concatMapM (\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+   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 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
+ compiler/GHC/Runtime/Heap/Inspect.hs view
@@ -0,0 +1,1355 @@+{-# 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 GhcPrelude++import GHC.Runtime.Interpreter as GHCi+import GHCi.RemoteTypes+import GHC.Driver.Types++import DataCon+import Type+import GHC.Types.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 GHC.Iface.Env+import Util+import VarSet+import BasicTypes       ( Boxity(..) )+import TysPrim+import PrelNames+import TysWiredIn+import GHC.Driver.Session+import Outputable as Ppr+import GHC.Char+import GHC.Exts.Heap+import GHC.Runtime.Heap.Layout ( 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("<function>")+  | 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 "<stablePtr>"+    | t == stableNamePrimTyCon       = text "<stableName>"+    | t == statePrimTyCon            = text "<statethread>"+    | t == proxyPrimTyCon            = text "<proxy>"+    | t == realWorldTyCon            = text "<realworld>"+    | t == threadIdPrimTyCon         = text "<ThreadId>"+    | t == weakPrimTyCon             = text "<Weak>"+    | t == arrayPrimTyCon            = text "<array>"+    | t == smallArrayPrimTyCon       = text "<smallArray>"+    | t == byteArrayPrimTyCon        = text "<bytearray>"+    | t == mutableArrayPrimTyCon     = text "<mutableArray>"+    | t == smallMutableArrayPrimTyCon = text "<smallMutableArray>"+    | t == mutableByteArrayPrimTyCon = text "<mutableByteArray>"+    | t == mutVarPrimTyCon           = text "<mutVar>"+    | t == mVarPrimTyCon             = text "<mVar>"+    | t == tVarPrimTyCon             = text "<tVar>"+    | 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:++  <datacon reptype>  =  <actual heap contents>++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 <base_type> <rtti_type>+-- 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
+ compiler/GHC/Runtime/Interpreter.hs view
@@ -0,0 +1,678 @@+{-# LANGUAGE RecordWildCards, ScopedTypeVariables, BangPatterns, CPP #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE TupleSections #-}++--+-- | Interacting with the 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+  , seqHValue++  -- * 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, stopInterp+  , iservCall, readIServ, writeIServ+  , purgeLookupSymbolCache+  , freeHValueRefs+  , mkFinalizedHValue+  , wormhole, wormholeRef+  , mkEvalOpts+  , fromEvalResult+  ) where++import GhcPrelude++import GHC.Runtime.Interpreter.Types+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 GHC.Driver.Types+import UniqFM+import Panic+import GHC.Driver.Session+import Exception+import BasicTypes+import FastString+import Util++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 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+-}+++-- | 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 i) -> withIServ_ 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 = case hsc_interp hsc_env of+   Nothing -> throwIO (InstallationError "Couldn't find a target code interpreter. Try with -fexternal-interpreter")+   Just i  -> action 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+  :: (MonadIO m, ExceptionMonad m)+  => IServ -> (IServInstance -> m (IServInstance, a)) -> m a+withIServ (IServ mIServState) action = do+  gmask $ \restore -> do+    state <- liftIO $ takeMVar mIServState++    iserv <- case state of+      -- start the external iserv process if we haven't done so yet+      IServPending conf ->+         liftIO (spawnIServ conf)+           `gonException` (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')+          `gonException` (liftIO $ putMVar mIServState (IServRunning iserv'))+    liftIO $ putMVar mIServState (IServRunning iserv'')+    return a++withIServ_+  :: (MonadIO m, ExceptionMonad m)+  => IServ -> (IServInstance -> m a) -> m a+withIServ_ iserv action = withIServ 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<n>) 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 str = withInterp hsc_env $ \case+#if defined(HAVE_INTERNAL_INTERPRETER)+  InternalInterp -> fmap fromRemotePtr <$> run (LookupSymbol (unpackFS str))+#endif++  ExternalInterp i -> withIServ 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      = []+    , iservConfig            = conf+    }++-- | 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)) ->+    gmask $ \_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 (iservConfig i))++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 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
+ compiler/GHC/Runtime/Linker.hs view
@@ -0,0 +1,1716 @@+{-# 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 GhcPrelude++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 TcRnMonad+import GHC.Driver.Packages as Packages+import GHC.Driver.Phases+import GHC.Driver.Finder+import GHC.Driver.Types+import Name+import NameEnv+import Module+import ListSetOps+import GHC.Runtime.Linker.Types (DynLinker(..), LinkerUnitId, PersistentLinkerState(..))+import GHC.Driver.Session+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 "GHC.ByteCode.Linker.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+   -- 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+    = 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 :: 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.++  | 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 (hsc_dflags hsc_env) == normalObjectSuffix && not (null haskellWays)+  = failNonStd (hsc_dflags hsc_env) srcspan++  | otherwise = return (Just (interpTag ++ "o"))+  where+    haskellWays = filter (not . wayRTSOnly) (ways (hsc_dflags hsc_env))+    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)+                                                    , Option "-Xlinker"+                                                    , Option "-rpath"+                                                    , Option "-Xlinker"+                                                    , Option lp ])+                                     (nub $ fst <$> temp_sos)+                        ++ concatMap+                             (\lp ->+                                 [ Option ("-L" ++ lp)+                                 , Option "-Xlinker"+                                 , Option "-rpath"+                                 , Option "-Xlinker"+                                 , Option lp+                                 ])+                             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+      | dynamicGhc = return ()+        -- We don't do any cleanup when linking objects with the+        -- dynamic linker.  Doing so introduces extra complexity for+        -- not much benefit.++      -- Code unloading currently disabled due to instability.+      -- See #16841.+      -- id False, so that the pattern-match checker doesn't complain+      | id False -- 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)+      | otherwise = return () -- see #16841++{- **********************************************************************++                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 -> UnitInfo -> 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+        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++        -- 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 -> UnitInfo -> 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.+    --+  = findDll   user `orElse`+    tryImpLib user `orElse`+    findDll   gcc  `orElse`+    findSysDll     `orElse`+    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+                     in apply $ short : full : map gcc files+     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)++-- 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+        ; mb_fwk <- findFile ps fwk_file+        ; case mb_fwk of+            Just fwk_path -> loadDLL hsc_env fwk_path+            Nothing       -> return (Just "not found") }+                -- Tried all our known library paths, but dlopen()+                -- has no built-in paths for frameworks: give up+   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"]++{- **********************************************************************++                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")
+ compiler/GHC/Runtime/Loader.hs view
@@ -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 GhcPrelude+import GHC.Driver.Session++import GHC.Runtime.Linker      ( linkModule, getHValue )+import GHC.Runtime.Interpreter ( wormhole, withInterp )+import GHC.Runtime.Interpreter.Types+import SrcLoc           ( noSrcSpan )+import GHC.Driver.Finder( findPluginModule, cannotFindModule )+import TcRnMonad        ( initTcInteractive, initIfaceTcRn )+import GHC.Iface.Load   ( loadPluginInterface )+import RdrName          ( RdrName, ImportSpec(..), ImpDeclSpec(..)+                        , ImpItemSpec(..), mkGlobalRdrEnv, lookupGRE_RdrName+                        , gre_name, mkRdrQual )+import OccName          ( OccName, mkVarOcc )+import GHC.Rename.Names ( gresFromAvails )+import GHC.Driver.Plugins+import PrelNames        ( pluginTyConName, frontendPluginTyConName )++import GHC.Driver.Types+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 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 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
compiler/GHC/Stg/CSE.hs view
@@ -93,10 +93,10 @@ import GHC.Stg.Syntax import Outputable import VarEnv-import CoreSyn (AltCon(..))+import GHC.Core (AltCon(..)) import Data.List (mapAccumL) import Data.Maybe (fromMaybe)-import CoreMap+import GHC.Core.Map import NameEnv import Control.Monad( (>=>) ) @@ -232,7 +232,7 @@  -- Functions to enter binders --- This is much simpler than the equivalent code in CoreSubst:+-- This is much simpler than the equivalent code in GHC.Core.Subst: --  * We do not substitute type variables, and --  * There is nothing relevant in IdInfo at this stage --    that needs substitutions.
+ compiler/GHC/Stg/DepAnal.hs view
@@ -0,0 +1,144 @@+{-# LANGUAGE CPP #-}++module GHC.Stg.DepAnal (depSortStgPgm) where++import GhcPrelude++import GHC.Stg.Syntax+import Id+import Name (Name, nameIsLocalOrFrom)+import NameEnv+import Outputable+import UniqSet (nonDetEltsUniqSet)+import VarSet+import Module (Module)++import Data.Graph (SCC (..))++--------------------------------------------------------------------------------+-- * 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:" $$ ppr 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 binds)
compiler/GHC/Stg/FVs.hs view
@@ -47,7 +47,7 @@ import GHC.Stg.Syntax import Id import VarSet-import CoreSyn    ( Tickish(Breakpoint) )+import GHC.Core    ( Tickish(Breakpoint) ) import Outputable import Util
compiler/GHC/Stg/Lift.hs view
@@ -20,9 +20,8 @@ import GhcPrelude  import BasicTypes-import DynFlags+import GHC.Driver.Session import Id-import IdInfo import GHC.Stg.FVs ( annBindingFreeVars ) import GHC.Stg.Lift.Analysis import GHC.Stg.Lift.Monad@@ -155,14 +154,9 @@   -> (Maybe OutStgBinding -> LiftM a)   -> LiftM a withLiftedBind top_lvl bind scope k-  | isTopLevel top_lvl-  = withCaffyness (is_caffy pairs) go-  | otherwise-  = go+  = withLiftedBindPairs top_lvl rec pairs scope (k . fmap (mkStgBinding rec))   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
compiler/GHC/Stg/Lift/Analysis.hs view
@@ -24,9 +24,9 @@  import BasicTypes import Demand-import DynFlags+import GHC.Driver.Session import Id-import GHC.Runtime.Layout ( WordOff )+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
compiler/GHC/Stg/Lift/Monad.hs view
@@ -11,7 +11,7 @@     -- $floats     FloatLang (..), collectFloats, -- Exported just for the docs     -- * Transformation monad-    LiftM, runLiftM, withCaffyness,+    LiftM, runLiftM,     -- ** Adding bindings     startBindingGroup, endBindingGroup, addTopStringLit, addLiftedBinding,     -- ** Substitution and binders@@ -26,10 +26,9 @@  import BasicTypes import CostCentre ( isCurrentCCS, dontCareCCS )-import DynFlags+import GHC.Driver.Session import FastString import Id-import IdInfo import Name import Outputable import OrdList@@ -81,14 +80,10 @@   -- '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+emptyEnv dflags = Env dflags emptySubst emptyVarEnv   -- Note [Handling floats]@@ -206,8 +201,7 @@ -- --     * '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.+--       such as 'DynFlags'. -- --     * @'OrdList' 'FloatLang'@: Writer output for the resulting STG program. --@@ -233,12 +227,6 @@   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@@ -276,26 +264,16 @@ -- 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.+-- 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)-  -- 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         . mkSysLocal (mkFastString str) uniq         $ ty   LiftM $ RWS.local
compiler/GHC/Stg/Lint.hs view
@@ -6,7 +6,7 @@ - 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+  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@@ -41,14 +41,14 @@  import GHC.Stg.Syntax -import DynFlags+import GHC.Driver.Session 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 GHC.Core         ( AltCon(..) ) import Name             ( getSrcLoc, nameIsLocalOrFrom ) import ErrUtils         ( MsgDoc, Severity(..), mkLocMessage ) import Type@@ -223,25 +223,6 @@ 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) []  {- ************************************************************************
compiler/GHC/Stg/Pipeline.hs view
@@ -19,12 +19,13 @@  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 Module           ( Module ) -import DynFlags+import GHC.Driver.Session import ErrUtils import UniqSupply import Outputable@@ -56,9 +57,16 @@         ; binds' <- runStgM 'g' $             foldM do_stg_pass binds (getStgToDo dflags) -        ; dump_when Opt_D_dump_stg_final "Final STG:" binds'--        ; return binds'+          -- 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
compiler/GHC/Stg/Stats.hs view
@@ -78,7 +78,7 @@  showStgStats prog   = "STG Statistics:\n\n"-    ++ concat (map showc (Map.toList (gatherStgStats prog)))+    ++ concatMap showc (Map.toList (gatherStgStats prog))   where     showc (x,n) = (showString (s x) . shows n) "\n"
compiler/GHC/Stg/Subst.hs view
@@ -13,7 +13,7 @@ import Util  -- | A renaming substitution from 'Id's to 'Id's. Like 'RnEnv2', but not--- maintaining pairs of substitutions. Like @"CoreSubst".'CoreSubst.Subst'@, but+-- 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
compiler/GHC/Stg/Unarise.hs view
@@ -203,12 +203,12 @@ import GhcPrelude  import BasicTypes-import CoreSyn+import GHC.Core import DataCon import FastString (FastString, mkFastString) import Id import Literal-import MkCore (aBSENT_SUM_FIELD_ERROR_ID)+import GHC.Core.Make (aBSENT_SUM_FIELD_ERROR_ID) import MkId (voidPrimId, voidArgId) import MonadUtils (mapAccumLM) import Outputable@@ -581,7 +581,7 @@        slotRubbishArg :: SlotTy -> StgArg       slotRubbishArg PtrSlot    = StgVarArg aBSENT_SUM_FIELD_ERROR_ID-                         -- See Note [aBSENT_SUM_FIELD_ERROR_ID] in MkCore+                         -- See Note [aBSENT_SUM_FIELD_ERROR_ID] in GHC.Core.Make       slotRubbishArg WordSlot   = StgLitArg (LitNumber LitNumWord 0 wordPrimTy)       slotRubbishArg Word64Slot = StgLitArg (LitNumber LitNumWord64 0 word64PrimTy)       slotRubbishArg FloatSlot  = StgLitArg (LitFloat 0)
compiler/GHC/StgToCmm.hs view
@@ -27,14 +27,13 @@ import GHC.StgToCmm.Ticky  import GHC.Cmm-import GHC.Cmm.Utils import GHC.Cmm.CLabel  import GHC.Stg.Syntax-import DynFlags+import GHC.Driver.Session import ErrUtils -import HscTypes+import GHC.Driver.Types import CostCentre import Id import IdInfo@@ -178,7 +177,7 @@ cgEnumerationTyCon :: TyCon -> FCode () cgEnumerationTyCon tycon   = do dflags <- getDynFlags-       emitRODataLits (mkLocalClosureTableLabel (tyConName tycon) NoCafRefs)+       emitRawRODataLits (mkLocalClosureTableLabel (tyConName tycon) NoCafRefs)              [ CmmLabelOff (mkLocalClosureLabel (dataConName con) NoCafRefs)                            (tagForCon dflags con)              | con <- tyConDataCons tycon]
compiler/GHC/StgToCmm/ArgRep.hs view
@@ -19,12 +19,12 @@  import GHC.StgToCmm.Closure ( idPrimRep ) -import GHC.Runtime.Layout            ( WordOff )+import GHC.Runtime.Heap.Layout            ( WordOff ) import Id               ( Id ) import TyCon            ( PrimRep(..), primElemRepSizeB ) import BasicTypes       ( RepArity ) import Constants        ( wORD64_SIZE )-import DynFlags+import GHC.Driver.Session  import Outputable import FastString
compiler/GHC/StgToCmm/Bind.hs view
@@ -29,9 +29,9 @@ import GHC.StgToCmm.Foreign    (emitPrimCall)  import GHC.Cmm.Graph-import CoreSyn          ( AltCon(..), tickishIsCode )+import GHC.Core          ( AltCon(..), tickishIsCode ) import GHC.Cmm.BlockId-import GHC.Runtime.Layout+import GHC.Runtime.Heap.Layout import GHC.Cmm import GHC.Cmm.Info import GHC.Cmm.Utils@@ -48,7 +48,7 @@ import BasicTypes import Outputable import FastString-import DynFlags+import GHC.Driver.Session  import Control.Monad @@ -87,15 +87,11 @@   -- 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
compiler/GHC/StgToCmm/CgUtils.hs view
@@ -24,7 +24,7 @@ import GHC.Cmm.Dataflow.Graph import GHC.Cmm.Utils import GHC.Cmm.CLabel-import DynFlags+import GHC.Driver.Session import Outputable  -- -----------------------------------------------------------------------------
compiler/GHC/StgToCmm/Closure.hs view
@@ -67,7 +67,7 @@ import GhcPrelude  import GHC.Stg.Syntax-import GHC.Runtime.Layout+import GHC.Runtime.Heap.Layout import GHC.Cmm import GHC.Cmm.Ppr.Expr() -- For Outputable instances @@ -85,7 +85,7 @@ import GHC.Types.RepType import BasicTypes import Outputable-import DynFlags+import GHC.Driver.Session import Util  import Data.Coerce (coerce)
compiler/GHC/StgToCmm/DataCon.hs view
@@ -20,7 +20,7 @@ import GhcPrelude  import GHC.Stg.Syntax-import CoreSyn  ( AltCon(..) )+import GHC.Core  ( AltCon(..) )  import GHC.StgToCmm.Monad import GHC.StgToCmm.Env@@ -33,11 +33,11 @@ import GHC.Cmm.Utils import GHC.Cmm.CLabel import GHC.Cmm.Graph-import GHC.Runtime.Layout+import GHC.Runtime.Heap.Layout import CostCentre import Module import DataCon-import DynFlags+import GHC.Driver.Session import FastString import Id import GHC.Types.RepType (countConRepArgs)@@ -104,17 +104,8 @@                 -- 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 }   ---------------------------------------------------------------
compiler/GHC/StgToCmm/Env.hs view
@@ -36,7 +36,7 @@ import GHC.Cmm.BlockId import GHC.Cmm.Expr import GHC.Cmm.Utils-import DynFlags+import GHC.Driver.Session import Id import GHC.Cmm.Graph import Name
compiler/GHC/StgToCmm/Expr.hs view
@@ -36,9 +36,9 @@ import GHC.Cmm.BlockId import GHC.Cmm hiding ( succ ) import GHC.Cmm.Info-import CoreSyn+import GHC.Core import DataCon-import DynFlags         ( mAX_PTR_TAG )+import GHC.Driver.Session         ( mAX_PTR_TAG ) import ForeignCall import Id import PrimOp@@ -324,8 +324,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.Op.Tidy (see+GHC.Core.Op.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@@ -336,7 +336,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.Op.Tidy.tidyIdBndr' was insufficient.  But now that CmmSink does the job we deleted the hacks. -} @@ -354,7 +354,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
compiler/GHC/StgToCmm/ExtCode.hs view
@@ -47,7 +47,7 @@ import GHC.Cmm.Graph  import GHC.Cmm.BlockId-import DynFlags+import GHC.Driver.Session import FastString import Module import UniqFM
compiler/GHC/StgToCmm/Foreign.hs view
@@ -35,9 +35,9 @@ import Type import GHC.Types.RepType import GHC.Cmm.CLabel-import GHC.Runtime.Layout+import GHC.Runtime.Heap.Layout import ForeignCall-import DynFlags+import GHC.Driver.Session import Maybes import Outputable import UniqSupply
compiler/GHC/StgToCmm/Heap.hs view
@@ -37,7 +37,7 @@ import GHC.Cmm.Graph  import GHC.Cmm.Dataflow.Label-import GHC.Runtime.Layout+import GHC.Runtime.Heap.Layout import GHC.Cmm.BlockId import GHC.Cmm import GHC.Cmm.Utils@@ -45,7 +45,7 @@ import IdInfo( CafInfo(..), mayHaveCafRefs ) import Id ( Id ) import Module-import DynFlags+import GHC.Driver.Session import FastString( mkFastString, fsLit ) import Panic( sorry ) @@ -196,7 +196,9 @@         | otherwise = []      static_link_field-        | is_caf || staticClosureNeedsLink (mayHaveCafRefs caf_refs) info_tbl+        | is_caf+        = [mkIntCLit dflags 0]+        | staticClosureNeedsLink (mayHaveCafRefs caf_refs) info_tbl         = [static_link_value]         | otherwise         = []
compiler/GHC/StgToCmm/Hpc.hs view
@@ -18,8 +18,8 @@ import Module import GHC.Cmm.Utils import GHC.StgToCmm.Utils-import HscTypes-import DynFlags+import GHC.Driver.Types+import GHC.Driver.Session  import Control.Monad @@ -41,7 +41,7 @@ initHpc this_mod (HpcInfo tickCount _hashNo)   = do dflags <- getDynFlags        when (gopt Opt_Hpc dflags) $-           do emitDataLits (mkHpcTicksLabel this_mod)+           emitRawDataLits (mkHpcTicksLabel this_mod)                            [ (CmmInt 0 W64)                            | _ <- take tickCount [0 :: Int ..]                            ]
compiler/GHC/StgToCmm/Layout.hs view
@@ -42,7 +42,7 @@ import GHC.StgToCmm.Utils  import GHC.Cmm.Graph-import GHC.Runtime.Layout+import GHC.Runtime.Heap.Layout import GHC.Cmm.BlockId import GHC.Cmm import GHC.Cmm.Utils@@ -52,7 +52,7 @@ import Id import TyCon             ( PrimRep(..), primRepSizeB ) import BasicTypes        ( RepArity )-import DynFlags+import GHC.Driver.Session import Module  import Util
compiler/GHC/StgToCmm/Monad.hs view
@@ -63,12 +63,12 @@  import GHC.Cmm import GHC.StgToCmm.Closure-import DynFlags+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.Layout+import GHC.Runtime.Heap.Layout import Module import Id import VarEnv
compiler/GHC/StgToCmm/Prim.hs view
@@ -35,7 +35,7 @@ import GHC.StgToCmm.Heap import GHC.StgToCmm.Prof ( costCentreFrom ) -import DynFlags+import GHC.Driver.Session import GHC.Platform import BasicTypes import GHC.Cmm.BlockId@@ -48,7 +48,7 @@ import GHC.Cmm.CLabel import GHC.Cmm.Utils import PrimOp-import GHC.Runtime.Layout+import GHC.Runtime.Heap.Layout import FastString import Outputable import Util@@ -1453,6 +1453,9 @@   CasMutVarOp -> alwaysExternal   CatchOp -> alwaysExternal   RaiseOp -> alwaysExternal+  RaiseDivZeroOp -> alwaysExternal+  RaiseUnderflowOp -> alwaysExternal+  RaiseOverflowOp -> alwaysExternal   RaiseIOOp -> alwaysExternal   MaskAsyncExceptionsOp -> alwaysExternal   MaskUninterruptibleOp -> alwaysExternal
compiler/GHC/StgToCmm/Prof.hs view
@@ -28,7 +28,7 @@ import GHC.StgToCmm.Closure import GHC.StgToCmm.Utils import GHC.StgToCmm.Monad-import GHC.Runtime.Layout+import GHC.Runtime.Heap.Layout  import GHC.Cmm.Graph import GHC.Cmm@@ -36,7 +36,7 @@ import GHC.Cmm.CLabel  import CostCentre-import DynFlags+import GHC.Driver.Session import FastString import Module import Outputable@@ -231,7 +231,7 @@               is_caf,   -- StgInt is_caf               zero dflags      -- struct _CostCentre *link             ]-  ; emitDataLits (mkCCLabel cc) lits+  ; emitRawDataLits (mkCCLabel cc) lits   }  emitCostCentreStackDecl :: CostCentreStack -> FCode ()@@ -247,7 +247,7 @@                 -- layouts of structs containing long-longs, simply                 -- pad out the struct with zero words until we hit the                 -- size of the overall struct (which we get via DerivedConstants.h)-           emitDataLits (mkCCSLabel ccs) (mk_lits cc)+           emitRawDataLits (mkCCSLabel ccs) (mk_lits cc)     Nothing -> pprPanic "emitCostCentreStackDecl" (ppr ccs)  zero :: DynFlags -> CmmLit
compiler/GHC/StgToCmm/Ticky.hs view
@@ -116,7 +116,7 @@ import GHC.Cmm.Graph import GHC.Cmm.Utils import GHC.Cmm.CLabel-import GHC.Runtime.Layout+import GHC.Runtime.Heap.Layout  import Module import Name@@ -126,7 +126,7 @@ import Outputable import Util -import DynFlags+import GHC.Driver.Session  -- Turgid imports for showTypeCategory import PrelNames@@ -240,7 +240,7 @@          ; fun_descr_lit <- newStringCLit $ showSDocDebug dflags ppr_for_ticky_name         ; arg_descr_lit <- newStringCLit $ map (showTypeCategory . idType . fromNonVoid) args-        ; emitDataLits ctr_lbl+        ; emitRawDataLits ctr_lbl         -- Must match layout of includes/rts/Ticky.h's StgEntCounter         --         -- krc: note that all the fields are I32 now; some were I16
compiler/GHC/StgToCmm/Utils.hs view
@@ -10,8 +10,9 @@  module GHC.StgToCmm.Utils (         cgLit, mkSimpleLit,-        emitDataLits, mkDataLits,-        emitRODataLits, mkRODataLits,+        emitRawDataLits, mkRawDataLits,+        emitRawRODataLits, mkRawRODataLits,+        emitDataCon,         emitRtsCall, emitRtsCallWithResult, emitRtsCallGen,         assignTemp, newTemp, @@ -36,7 +37,7 @@         cmmUntag, cmmIsTagged,          addToMem, addToMemE, addToMemLblE, addToMemLbl,-        mkWordCLit,+        mkWordCLit, mkByteStringCLit,         newStringCLit, newByteStringCLit,         blankWord, @@ -57,7 +58,7 @@ import GHC.Cmm.Graph as CmmGraph import GHC.Platform.Regs import GHC.Cmm.CLabel-import GHC.Cmm.Utils+import GHC.Cmm.Utils hiding (mkDataLits, mkRODataLits, mkByteStringCLit) import GHC.Cmm.Switch import GHC.StgToCmm.CgUtils @@ -65,20 +66,22 @@ import IdInfo import Type import TyCon-import GHC.Runtime.Layout+import GHC.Runtime.Heap.Layout import Module import Literal import Digraph import Util import Unique import UniqSupply (MonadUnique(..))-import DynFlags+import GHC.Driver.Session import FastString import Outputable import GHC.Types.RepType+import CostCentre  import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as BS8+import qualified Data.ByteString as BS import qualified Data.Map as M import Data.Char import Data.List@@ -270,13 +273,43 @@ -- ------------------------------------------------------------------------- -emitDataLits :: CLabel -> [CmmLit] -> FCode ()+mkRawDataLits :: Section -> CLabel -> [CmmLit] -> GenCmmDecl CmmStatics info stmt+-- Build a data-segment data block+mkRawDataLits section lbl lits+  = CmmData section (CmmStaticsRaw lbl (map CmmStaticLit lits))++mkRawRODataLits :: CLabel -> [CmmLit] -> GenCmmDecl CmmStatics info stmt+-- Build a read-only data block+mkRawRODataLits lbl lits+  = mkRawDataLits section lbl lits+  where+    section | any needsRelocation lits = Section RelocatableReadOnlyData lbl+            | otherwise                = Section ReadOnlyData lbl+    needsRelocation (CmmLabel _)      = True+    needsRelocation (CmmLabelOff _ _) = True+    needsRelocation _                 = False++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) (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++emitRawDataLits :: CLabel -> [CmmLit] -> FCode () -- Emit a data-segment data block-emitDataLits lbl lits = emitDecl (mkDataLits (Section Data lbl) lbl lits)+emitRawDataLits lbl lits = emitDecl (mkRawDataLits (Section Data lbl) lbl lits) -emitRODataLits :: CLabel -> [CmmLit] -> FCode ()+emitRawRODataLits :: CLabel -> [CmmLit] -> FCode () -- Emit a read-only data block-emitRODataLits lbl lits = emitDecl (mkRODataLits lbl lits)+emitRawRODataLits lbl lits = emitDecl (mkRawRODataLits 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,
compiler/GHC/ThToHs.hs view
@@ -853,7 +853,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@@ -924,7 +924,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@@ -1126,7 +1126,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@@ -1159,7 +1159,7 @@                     ; 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@@ -1594,8 +1594,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. @@ -1996,11 +1997,11 @@  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+specially in `GHC.HsToCore.Quote`, `GHC.ThToHs`, and `typecheck/TcSplice.hs`:     (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)
+ compiler/GHC/Types/Name/Shape.hs view
@@ -0,0 +1,268 @@+{-# LANGUAGE CPP #-}++module GHC.Types.Name.Shape(+    NameShape(..),+    emptyNameShape,+    mkNameShape,+    extendNameShape,+    nameShapeExports,+    substNameShape,+    maybeSubstNameShape,+    ) where++#include "HsVersions.h"++import GhcPrelude++import Outputable+import GHC.Driver.Types+import Module+import UniqFM+import Avail+import FieldLabel++import Name+import NameEnv+import TcRnMonad+import Util+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 <m>, 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)
− compiler/backpack/DriverBkp.hs 
@@ -1,827 +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 GHC.Iface.Utils-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-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 (getUnitInfoMap 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=<A>]@ in a--- unit file, return the 'UnitId' corresponding to @p[A=<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 (getUnitInfoMap 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))---- | Register a new virtual package database containing a single unit-addPackage :: GhcMonad m => UnitInfo -> m ()-addPackage pkg = do-    dflags <- GHC.getSessionDynFlags-    case pkgDatabase dflags of-        Nothing -> panic "addPackage: called too early"-        Just dbs -> do-         let newdb = PackageDatabase-               { packageDatabasePath  = "(in memory " ++ showSDoc dflags (ppr (unitId pkg)) ++ ")"-               , packageDatabaseUnits = [pkg]-               }-         _ <- GHC.setSessionDynFlags (dflags { pkgDatabase = Just (dbs ++ [newdb]) })-         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 lookupUnit 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)-              -> 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 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
− compiler/backpack/NameShape.hs 
@@ -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 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 <m>, 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)
− compiler/coreSyn/CoreLint.hs 
@@ -1,2799 +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 GHC.Types.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 <body>-That is, use a type let.   See Note [Type let] in CoreSyn.--However, when linting <body> 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 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.--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 -> do-           let sty = mkDumpStyle dflags 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 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 GHC.IfaceToCore.---}--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 (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 }--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)
− compiler/deSugar/Coverage.hs 
@@ -1,1355 +0,0 @@-{--(c) Galois, 2006-(c) University of Glasgow, 2007--}--{-# LANGUAGE NondecreasingIndentation, RecordWildCards #-}-{-# LANGUAGE ViewPatterns #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE DeriveFunctor #-}--{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}--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 GHC.Cmm.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" FormatHaskell-       (pprLHsBinds binds1)--     return (binds1, HpcInfo tickCount hashNo, Just 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 ModBreaks-mkModBreaks hsc_env mod count entries-  | HscInterpreted <- hscTarget (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 emptyModBreaks-                       { modBreaks_flags = breakArray-                       , modBreaks_locs  = locsTicks-                       , modBreaks_vars  = varsTicks-                       , modBreaks_decls = declsTicks-                       , modBreaks_ccs   = ccs-                       }-  | otherwise = return emptyModBreaks--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 -- <tab> 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)--  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 $ 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 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 (L 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 $ 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-addTickLHsBind bind@(L _ (XHsBindsLR {})) = return 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 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 (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 (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 (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))-addTickTupArg (L _ (XTupArg nec)) = noExtCon nec---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' }-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 (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-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@(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 (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' }) }--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 (L 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 (L 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 (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 (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 (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 = (L l matches) }) = do-  matches' <- mapM (liftL addTickCmdMatch) matches-  return $ mg { mg_alts = L 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 (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-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 (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"-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 (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-                         }--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 (hscTarget dflags == HscInterpreted) 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---- | 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 (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 -> 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 (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 =- 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-     ( L pos $ HsTick noExtField (HpcTick (this_mod env) c)-          $ L 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 (L _ (Match { m_grhss = GRHSs _ grhss _ }))-          = length grhss-        matchCount (L _ (Match { m_grhss = XGRHSs nec }))-          = noExtCon nec-        matchCount (L _ (XMatch nec)) = noExtCon nec--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_<module>()`, 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
− compiler/deSugar/Desugar.hs 
@@ -1,545 +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"-                         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 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 (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)-        } } }-dsRule (L _ (XRuleDecl nec)) = noExtCon nec--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 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.--}
− compiler/deSugar/DsArrows.hs 
@@ -1,1271 +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 #-}--{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}--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 (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-          = (L _ [L _ (Match { m_pats  = pats-                             , m_grhss = GRHSs _ [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 = 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 = 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)---- 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 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 (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-                       (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 [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 (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]-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-                        (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 }))-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) (L loc (GRHS x stmts _))-  = (leaves, L 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 (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 (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 _ (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
− compiler/deSugar/DsBinds.hs 
@@ -1,1325 +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 #-}--{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}--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 (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-                         , 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 = 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 `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 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 <body>--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 <body>--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 <body>` 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` <body>---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 (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, args) -> do--       { this_mod <- getModule-       ; let fn_unf    = realIdUnfolding poly_id-             spec_unf  = specUnfolding dflags spec_bndrs core_app arity_decrease fn_unf-             spec_id   = mkLocalId spec_name spec_ty-                            `setInlinePragma` inl_prag-                            `setIdUnfolding`  spec_unf-             arity_decrease = count isValArg args - count isId spec_bndrs--       ; rule <- dsMkUserRule this_mod is_local_id-                        (mkFastString ("SPEC " ++ showPpr dflags poly_name))-                        rule_act poly_name-                        rule_bndrs 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)) (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 = <rhs>-        ... 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 = <rhs> 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)
− compiler/deSugar/DsBinds.hs-boot 
@@ -1,6 +0,0 @@-module DsBinds where-import DsMonad     ( DsM )-import CoreSyn     ( CoreExpr )-import TcEvidence (HsWrapper)--dsHsWrapper :: HsWrapper -> DsM (CoreExpr -> CoreExpr)
− compiler/deSugar/DsCCall.hs 
@@ -1,381 +0,0 @@-{--(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 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--{--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<r># 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 = (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
− compiler/deSugar/DsExpr.hs 
@@ -1,1180 +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 #-}--{-# OPTIONS_GHC -Wno-incomplete-uni-patterns   #-}-{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}--module DsExpr ( dsExpr, dsLExpr, dsLExprNoLP, dsLocalBinds-              , dsValBinds, dsLit, dsSyntaxExpr-              , dsHandleMonadicFailure ) 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 (L _   (EmptyLocalBinds _))  body = return body-dsLocalBinds (L loc (HsValBinds _ binds)) body = putSrcSpanDs loc $-                                                 dsValBinds binds body-dsLocalBinds (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 (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-  | [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 = 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 (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 <- 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 (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 (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 _ (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 _ (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.--Operator sections.  At first it looks as if we can convert-\begin{verbatim}-        (expr op)-\end{verbatim}-to-\begin{verbatim}-        \x -> op expr x-\end{verbatim}--But no!  expr might be a redex, and we can lose laziness badly this-way.  Consider-\begin{verbatim}-        map (expr op) xs-\end{verbatim}-for example.  So we convert instead to-\begin{verbatim}-        let y = expr in \x -> op y x-\end{verbatim}-If \tr{expr} is actually just a variable, say, then the simplifier-will sort it out.--}--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') }--ds_expr _ (SectionL _ expr op)       -- Desugar (e !) to ((!) e)-  = do { op' <- dsLExpr op-       ; dsWhenNoErrs (dsLExprNoLP expr)-                      (\expr' -> mkCoreAppDs (text "sectionl" <+> ppr expr) op' expr') }---- dsLExpr (SectionR op expr)   -- \ x -> op x expr-ds_expr _ e@(SectionR _ op expr) = do-    core_op <- dsLExpr op-    -- for the type of x, we need the type of op's 2nd argument-    let (x_ty:y_ty:_, _) = splitFunTys (exprType core_op)-        -- See comment with SectionL-    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) (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) (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 _ (HsPragE _ prag expr) =-  ds_prag_expr prag 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 (L _ stmts)) = dsListComp stmts res_ty-ds_expr _ (HsDo _ DoExpr        (L _ stmts)) = dsDo stmts-ds_expr _ (HsDo _ GhciStmtCtxt  (L _ stmts)) = dsDo stmts-ds_expr _ (HsDo _ MDoExpr       (L _ stmts)) = dsDo stmts-ds_expr _ (HsDo _ MonadComp     (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@(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 (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 _ hs_wrapper x ps) = dsBracket hs_wrapper 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-     }---- 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--ds_prag_expr :: HsPragE GhcTc -> LHsExpr GhcTc -> DsM CoreExpr-ds_prag_expr (HsPragSCC _ _ cc) expr = 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 (getLoc expr) flavour) count True)-               <$> dsLExpr expr-      else dsLExpr expr-ds_prag_expr (HsPragCore _ _ _) expr-  = dsLExpr expr-ds_prag_expr (HsPragTick _ _ _ _) expr = do-  dflags <- getDynFlags-  if gopt Opt_Hpc dflags-    then panic "dsExpr:HsPragTick"-    else dsLExpr expr-ds_prag_expr (XHsPragE x) _ = noExtCon x---------------------------------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 | 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 ((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 <- dsHandleMonadicFailure 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 <- 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 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--dsHandleMonadicFailure :: LPat GhcTc -> MatchResult -> SyntaxExpr GhcTc -> DsM CoreExpr-    -- In a do expression, pattern-match failure just calls-    -- the monadic 'fail' rather than throwing an exception-dsHandleMonadicFailure 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 :: DynFlags -> Located 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 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)-         ]--{--************************************************************************-*                                                                      *-   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 _ (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-    ]
− compiler/deSugar/DsExpr.hs-boot 
@@ -1,12 +0,0 @@-module DsExpr where-import GHC.Hs      ( HsExpr, LHsExpr, LHsLocalBinds, LPat, SyntaxExpr )-import DsMonad     ( DsM, MatchResult )-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--dsHandleMonadicFailure :: LPat GhcTc -> MatchResult -> SyntaxExpr GhcTc -> DsM CoreExpr
− compiler/deSugar/DsForeign.hs 
@@ -1,820 +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 #-}--{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}--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 GHC.Types.RepType-import TyCon-import Coercion-import TcEnv-import TcType--import GHC.Cmm.Expr-import GHC.Cmm.Utils-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 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-    fives <- mapM do_ldecl fos-    let-        (hs, cs, idss, bindss) = unzip4 fives-        fe_ids = concat idss-        fe_init_code = map foreignExportInitialiser fe_ids-    ---    return (ForeignStubs-             (vcat hs)-             (vcat cs $$ vcat fe_init_code),-            foldr (appOL . toOL) nilOL bindss)-  where-   do_ldecl (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 = 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], [])-   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  = coercionLKind 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 (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 :: 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 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 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 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'' <arg info> 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                       = coercionLKind 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-     ]---foreignExportInitialiser :: Id -> SDoc-foreignExportInitialiser hs_fn =-   -- 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)-   vcat-    [ text "static void stginit_export_" <> ppr hs_fn-         <> text "() __attribute__((constructor));"-    , text "static void stginit_export_" <> ppr hs_fn <> text "()"-    , braces (text "foreignExportStablePtr"-       <> parens (text "(StgPtr) &" <> ppr hs_fn <> text "_closure")-       <> semi)-    ]---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-     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"
− compiler/deSugar/DsGRHSs.hs 
@@ -1,156 +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 (L _ (GRHS _ guards rhs))-  = matchGuards (map unLoc guards) (PatGuard hs_ctx) rhs rhs_ty-dsGRHS _ _ (L _ (XGRHS nec)) = noExtCon nec--{--************************************************************************-*                                                                      *-*  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}--}
− compiler/deSugar/DsListComp.hs 
@@ -1,676 +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 ( dsHandleMonadicFailure, 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 <<e>> TE <<L>>--(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 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  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 ((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 <- 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) 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])) }
− compiler/deSugar/DsMeta.hs 
@@ -1,2957 +0,0 @@-{-# LANGUAGE CPP, TypeFamilies #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE ViewPatterns #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE UndecidableInstances #-}--{-# 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/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 TcEvidence-import Control.Monad.Trans.Reader-import Control.Monad.Trans.Class-import Class-import HscTypes ( MonadThings )-import DataCon-import Var-import DsBinds--import GHC.TypeLits-import Data.Kind (Constraint)--import Data.ByteString ( unpack )-import Control.Monad-import Data.List--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 = mkForAllTys tyvars $-                          mkInvisFunTy (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--------------------------------------------------------------------------------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 }-    do_brack (XBracket nec) = noExtCon nec--{--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 `TcSplice`. 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 (L loc (Warning _ thing _))-      = notHandledL loc "WARNING and DEPRECATION pragmas" $-                    text "Pragma for declaration of" <+> ppr thing-    no_warn (L _ (XWarnDecl nec)) = noExtCon nec-    no_doc (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 (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 surprisingly 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 -> 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  <- 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 <- repListM decTyConName return (ats1 ++ atds1 ++ sigs_binds)-              ; decls2 <- repClass cxt1 cls1 bndrs fds1 decls1-              ; wrapGenSyms ss decls2 }-       ; return $ Just (loc, dec)-       }--repTyClD (L _ (XTyClDecl nec)) = noExtCon nec----------------------------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) }-repRoleD (L _ (XRoleAnnotDecl nec)) = noExtCon nec----------------------------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-    XStandaloneKindSig nec -> noExtCon nec----------------------------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 }-       }-repDataDefn _ _ (XHsDataDefn nec) = noExtCon nec--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)-       }-repFamilyDecl (L _ (XFamilyDecl nec)) = noExtCon nec---- | 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' }-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-                              -> 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"-repFamilyResultSigToMaybeKind (XFamilyResultSig nec) = noExtCon nec---- | 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) }-repInstD (L _ (XInstDecl nec)) = noExtCon nec--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 class and instance declarations]-               ; (ss, sigs_binds) <- rep_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-repClsInstD (XClsInstDecl nec) = noExtCon nec--repStandaloneDerivD :: LDerivDecl GhcRn -> MetaM (SrcSpan, Core (M TH.Dec))-repStandaloneDerivD (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 (L _ (XDerivDecl nec)) = noExtCon nec--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 tyVarBndrTyConName-                                        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"-repTyFamEqn (XHsImplicitBndrs nec) = noExtCon nec-repTyFamEqn (HsIB _ (XFamEqn nec)) = noExtCon nec--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 tyVarBndrTyConName-                                        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"--repDataFamInstD (DataFamInstDecl (XHsImplicitBndrs nec))-  = noExtCon nec-repDataFamInstD (DataFamInstDecl (HsIB _ (XFamEqn nec)))-  = noExtCon nec--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)-repForD (L _ (XForeignDecl nec)) = noExtCon nec--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 }-rep_fix_d _ (XFixitySig nec) = noExtCon nec--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 tyVarBndrTyConName-                         ; 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) }-repRuleD (L _ (XRuleDecl nec)) = noExtCon nec--ruleBndrNames :: LRuleBndr GhcRn -> [Name]-ruleBndrNames (L _ (RuleBndr _ n))      = [unLoc n]-ruleBndrNames (L _ (RuleBndrSig _ n sig))-  | HsWC { hswc_body = HsIB { hsib_ext = vars }} <- sig-  = unLoc n : vars-ruleBndrNames (L _ (RuleBndrSig _ _ (HsWC _ (XHsImplicitBndrs nec))))-  = noExtCon nec-ruleBndrNames (L _ (RuleBndrSig _ _ (XHsWildCardBndrs nec)))-  = noExtCon nec-ruleBndrNames (L _ (XRuleBndr nec)) = noExtCon nec--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 (hsSigWcType sig)-       ; rep2 typedRuleVarName [n', ty'] }-repRuleBndr (L _ (XRuleBndr nec)) = noExtCon nec--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) }-repAnnD (L _ (XAnnDecl nec)) = noExtCon nec--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_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 (L _ (XConDecl nec)) = noExtCon nec---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 }))-  = do MkC dcs' <- repDerivStrategy dcs-       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-repDerivClause (L _ (XHsDerivingClause nec)) = noExtCon nec--rep_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 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] -> 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-rep_sig (L _ (XSig nec)) = noExtCon nec--rep_ty_sig :: Name -> SrcSpan -> LHsSigType GhcRn -> Located Name-           -> MetaM (SrcSpan, Core (M TH.Dec))--- 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 <- repListM tyVarBndrTyConName 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-                  -> MetaM (SrcSpan, Core (M TH.Dec))--- 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 <- repListM tyVarBndrTyConName rep_in_scope_tv univs-       ; th_exis  <- repListM tyVarBndrTyConName 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-              -> 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----------------------------------------------------------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 :: [LHsTyVarBndr GhcRn]  -- the binders to be added-                -> (Core [(M TH.TyVarBndr)] -> 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 tyVarBndrTyConName 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 [(M TH.TyVarBndr)] -> 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 (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 [(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 tyVarBndrTyConName 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 :: LHsTyVarBndr GhcRn-                     -> Core TH.Name -> MetaM (Core (M TH.TyVarBndr))-repTyVarBndrWithKind (L _ (UserTyVar _ _)) nm-  = repPlainTV nm-repTyVarBndrWithKind (L _ (KindedTyVar _ _ ki)) nm-  = repLTy ki >>= repKindedTV nm-repTyVarBndrWithKind (L _ (XTyVarBndr nec)) _ = noExtCon nec---- | Represent a type variable binder-repTyVarBndr :: LHsTyVarBndr GhcRn -> MetaM (Core (M TH.TyVarBndr))-repTyVarBndr (L _ (UserTyVar _ (L _ nm)) )-  = do { nm' <- lookupBinder nm-       ; repPlainTV nm' }-repTyVarBndr (L _ (KindedTyVar _ (L _ nm) ki))-  = do { nm' <- lookupBinder nm-       ; ki' <- repLTy ki-       ; repKindedTV nm' ki' }-repTyVarBndr (L _ (XTyVarBndr nec)) = noExtCon nec---- 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 }-repHsSigType (XHsImplicitBndrs nec) = noExtCon nec--repHsSigWcType :: LHsSigWcType GhcRn -> MetaM (Core (M TH.Type))-repHsSigWcType (HsWC { hswc_body = sig1 })-  = repHsSigType sig1-repHsSigWcType (XHsWildCardBndrs nec) = noExtCon nec---- 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 ForallInvis@ 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_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 _ _ (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 -> MetaM (Core (M TH.TyLit))-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)-            -> 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 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 -> 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)-  XAmbiguousFieldOcc nec -> noExtCon nec--        -- 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))- | 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 -> 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 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 uv-                               sname <- repNameS occ-                               repUnboundVar sname--repE e@(HsPragE _ HsPragCore {} _)   = notHandled "Core annotations" (ppr e)-repE e@(HsPragE _ HsPragSCC  {} _)   = notHandled "Cost centres" (ppr e)-repE e@(HsPragE _ HsPragTick {} _)   = notHandled "Tick Pragma" (ppr e)-repE (XExpr nec)           = noExtCon nec-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 }}}-repClauseTup (L _ (Match _ _ _ (XGRHSs nec))) = noExtCon nec-repClauseTup (L _ (XMatch nec)) = noExtCon nec--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) }-repLGRHS (L _ (XGRHS nec)) = noExtCon nec--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)-      XAmbiguousFieldOcc nec -> noExtCon nec------------------------------------------------------------------------------------ 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 [ 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) }-     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 (XStmtLR nec : _) = noExtCon nec-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 (HsIPBinds _ (XHsIPBinds nec)) = noExtCon nec--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 <- coreListM decTyConName-                                (de_loc (sort_by_loc prs))-        ; return (ss, core_list) }-repBinds (XHsLocalBindsLR nec) = noExtCon nec--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_bind (L _ (XIPBind nec)) = noExtCon nec--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 _ (FunBind { fun_matches = XMatchGroup nec })) = noExtCon nec--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 _ (PatBind _ _ (XGRHSs nec) _)) = noExtCon nec--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--rep_bind (L _ (PatSynBind _ (XPatSynBind nec))) = noExtCon nec-rep_bind (L _ (XHsBindsLR nec)) = noExtCon nec--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') }-repPatSynDir (ExplicitBidirectional (XMatchGroup nec)) = noExtCon nec--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 _ (Match { m_grhss = GRHSs _ [L _ (GRHS _ [] _)]-                                          (L _ (XHsLocalBindsLR nec)) } ))- = noExtCon nec--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 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 <- 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 (hsSigWcType t)-                         ; repPsig p' t' }-repP (SplicePat _ splice) = repSplice splice-repP (XPat nec) = noExtCon nec-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] -> 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) 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 <module>:<name> 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 = 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. (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]) = tcSplitAppTys (exprType b)-        -- b :: m 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    <- 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 { dflags <- getDynFlags-      ; rep2 unboxedSumPName [ p-                             , mkIntExprInt dflags alt-                             , mkIntExprInt dflags 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 { dflags <- getDynFlags-      ; rep2 unboxedSumEName [ e-                             , mkIntExprInt dflags alt-                             , mkIntExprInt dflags 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 :: Core [(M TH.Stmt)] -> MetaM (Core (M TH.Exp))-repDoE (MkC ss) = rep2 doEName [ss]--repMDoE :: Core [(M TH.Stmt)] -> MetaM (Core (M TH.Exp))-repMDoE (MkC ss) = rep2 mdoEName [ss]--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)-                 -> MetaM (Core (Maybe (M TH.DerivStrategy)))-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 = 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 ps-         rep2 normalCName [unC con, unC arg_tys]--repConstr (PrefixCon ps) (Just res_ty) cons-    = do arg_tys     <- repListM bangTypeTyConName 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 <- 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 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 [(M TH.TyVarBndr)] -> 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 dflags <- getDynFlags-                     rep2 tupleTName [mkIntExprInt dflags i]--repUnboxedTupleTyCon :: Int -> MetaM (Core (M TH.Type))--- Note: not Core Int; it's easier to be direct here-repUnboxedTupleTyCon i = do dflags <- getDynFlags-                            rep2 unboxedTupleTName [mkIntExprInt dflags i]--repUnboxedSumTyCon :: TH.SumArity -> MetaM (Core (M TH.Type))--- Note: not Core TH.SumArity; it's easier to be direct here-repUnboxedSumTyCon arity = do dflags <- getDynFlags-                              rep2 unboxedSumTName [mkIntExprInt dflags arity]--repArrowTyCon :: MetaM (Core (M TH.Type))-repArrowTyCon = rep2 arrowTName []--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 dflags <- getDynFlags-                             rep2 promotedTupleTName [mkIntExprInt dflags i]--repPromotedNilTyCon :: MetaM (Core (M TH.Type))-repPromotedNilTyCon = rep2 promotedNilTName []--repPromotedConsTyCon :: MetaM (Core (M TH.Type))-repPromotedConsTyCon = rep2 promotedConsTName []-------------- TyVarBndrs ---------------------repPlainTV :: Core TH.Name -> MetaM (Core (M TH.TyVarBndr))-repPlainTV (MkC nm) = rep2 plainTVName [nm]--repKindedTV :: Core TH.Name -> Core (M TH.Kind) -> MetaM (Core (M TH.TyVarBndr))-repKindedTV (MkC nm) (MkC ki) = rep2 kindedTVName [nm, ki]---------------------------------------------------------------       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 dflags   <- getDynFlags-       word8_ty <- lookupType word8TyConName-       let w8s = unpack bs-           w8s_expr = map (\w8 -> mkCoreConApps word8DataCon-                                  [mkWordLit dflags (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 = do integer_ty <- lookupType integerTyConName-                   return $ HsInteger NoSourceText i integer_ty--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-repOverloadedLiteral (XOverLit nec) = noExtCon nec--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 dflags <- getDynFlags-                  return (MkC (mkIntExprInt dflags i))--coreIntegerLit :: MonadThings m => Integer -> m (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 -> 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
− compiler/deSugar/DsMonad.hs 
@@ -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 GHC.IfaceToCore-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- = mkSysLocalOrCoVarM (fsLit "ds")  -- like newSysLocalDs, but we allow covars--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 = 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 :: [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 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 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]
− compiler/deSugar/DsUsage.hs 
@@ -1,375 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE TupleSections #-}-{-# LANGUAGE ViewPatterns #-}--{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}--module DsUsage (-    -- * Dependency/fingerprinting code (used by GHC.Iface.Utils)-    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]-   ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--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 :: 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 [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 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!-        -}
− compiler/deSugar/DsUtils.hs 
@@ -1,1001 +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 )-import Data.List.NonEmpty (NonEmpty(..))-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.--}--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 :: 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 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-  -> NonEmpty (CaseAlt DataCon) -- ^ Alternatives (bndrs *include* tyvars, dicts)-  -> MatchResult-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-mkCoSynCaseMatchResult var ty alt = MatchResult CanFail $ 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]-    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 -> NonEmpty (CaseAlt DataCon) -> MatchResult-mkDataConCase var ty alts@(alt1 :| _) = MatchResult fail_flag mk_case-  where-    con1          = alt_pat alt1-    tycon         = dataConTyCon con1-    data_cons     = tyConDataCons tycon-    match_results = fmap alt_result alts--    sorted_alts :: NonEmpty (CaseAlt DataCon)-    sorted_alts  = NEL.sortWith (dataConTag . alt_pat) 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 ++ NEL.toList 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 _ <- NEL.toList match_results]-              | otherwise-              = CanFail--    mentioned_constructors = mkUniqSet $ map alt_pat $ NEL.toList 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-  | 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 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 (L _ (ParPat _ p))  = strip_bangs p-strip_bangs (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  = 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 :: [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@(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)---- | Unconditionally make a 'Pat' strict.-addBang :: LPat GhcTc -- ^ Original pattern-        -> LPat GhcTc -- ^ Banged pattern-addBang = go-  where-    go lp@(L l p)-      = case p of-           ParPat x p    -> L l (ParPat x (go p))-           LazyPat _ lp' -> L l (BangPat noExtField lp')-                                  -- Should we bring the extension value over?-           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
− compiler/deSugar/ExtractDocs.hs 
@@ -1,362 +0,0 @@--- | Extract docs from the renamer output so they can be be serialized.-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE ViewPatterns #-}--{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}--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.Pat-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 :: XRec pass Pat ~ Located (Pat pass) =>-                     HsDecl pass -> [IdP pass]-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 = 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 = 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 = 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)-                   | (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 <- [M.lookup 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_fvf = ForallInvis-                      , 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 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
− compiler/deSugar/Match.hs 
@@ -1,1146 +0,0 @@-{--(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 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.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 <binds>-in  <matching-code>-\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 (v:vs) 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-    vars = v :| vs--    dropGroup :: Functor f => f (PatGroup,EquationInfo) -> f EquationInfo-    dropGroup = fmap snd--    match_groups :: [NonEmpty (PatGroup,EquationInfo)] -> DsM (NonEmpty MatchResult)-    -- Result list of [MatchResult] 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-    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)--- 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 :: NonEmpty MatchId -> Type -> NonEmpty 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 $ NEL.toList $ shiftEqns eqns--matchBangs :: NonEmpty MatchId -> Type -> NonEmpty EquationInfo -> DsM MatchResult-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--- 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 $ 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--- 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 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-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 $ 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 (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 _ (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--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 (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 (CoPat x w p t)-  = tidy1 v o (CoPat x 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@(ConPatOut { pat_con = 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 (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 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 = 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 (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 desugaring 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 _ (L _ (XMatch nec)) = noExtCon nec--    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] -> [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 dflags eqns-  = NEL.groupBy same_gp $ [(patGroup dflags (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 (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 (L _ (Present _ e1)) (L _ (Present _ e2)) = lexp e1 e2-    tup_arg (L _ (Missing t1))   (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 = 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 _ (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 _ (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.--}
− compiler/deSugar/Match.hs-boot 
@@ -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
− compiler/deSugar/MatchCon.hs 
@@ -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 #-}--{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}--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)-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--- 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"--matchPatSyn :: NonEmpty Id-            -> Type-            -> NonEmpty 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"--type ConArgPats = HsConDetails (LPat GhcTc) (HsRecFields GhcTc (LPat GhcTc))--matchOneConLike :: [Id]-                -> Type-                -> NonEmpty 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 = 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 (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 :: [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-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.---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.---}
− compiler/deSugar/MatchLit.hs 
@@ -1,520 +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 #-}--{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}--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.List.NonEmpty (NonEmpty(..))-import qualified Data.List.NonEmpty as NEL-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 bounds 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 (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 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 :: NonEmpty Id-              -> Type -- ^ Type of the whole case expression-              -> NonEmpty (NonEmpty EquationInfo) -- ^ All PgLits-              -> DsM MatchResult--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)-    match_group eqns@(firstEqn :| _)-        = do { dflags <- getDynFlags-             ; let LitPat _ hs_lit = firstPat firstEqn-             ; match_result <- match vars ty (NEL.toList $ 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)-------------------------------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 :: NonEmpty Id -> Type -> NonEmpty EquationInfo -> DsM MatchResult-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  <expr-for-a-successful-match>-    else-        <try-next-pattern-or-whatever>-\end{verbatim}--}--matchNPlusKPats :: NonEmpty Id -> Type -> NonEmpty EquationInfo -> DsM MatchResult--- 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)   $-                   adjustMatchResult (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)
− compiler/ghci/ByteCodeAsm.hs 
@@ -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 GHC.Runtime.Layout-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-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
− compiler/ghci/ByteCodeGen.hs 
@@ -1,2036 +0,0 @@-{-# LANGUAGE CPP, MagicHash, RecordWildCards, BangPatterns #-}-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# OPTIONS_GHC -fprof-auto-top #-}-{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}------  (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 GHC.Types.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 GHC.Runtime.Layout hiding (WordOff, ByteOff, wordsToBytes)-import GHC.Data.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" 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 "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")--      -- 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 "ByteCodeGen.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 :: 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 -}] (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 (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]-    -> 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-         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 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 (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<n> 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<n,fvs> 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# <type> 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/restore 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) 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):--            <arg_n>-            ...-            <arg_1>-            Addr# address_of_C_fn-            <placeholder-for-result#> (must be an unboxed type)--         The interpreter then calls the marshall code mentioned-         in the CCALL insn, passing it (& <placeholder-for-result#>),-         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-     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 <lbl for first data con>-                  JMP L_Exit--        L1:     TESTEQ_I 1 L2-                  PUSH_G <lbl for second data con>-                  JMP L_Exit-        ...etc...-        Ln:     TESTEQ_I n L_fail-                  PUSH_G <lbl for last data con>-                  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-           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"
− compiler/ghci/ByteCodeInstr.hs 
@@ -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 GHC.Runtime.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 "<cc>"---- -------------------------------------------------------------------------------- 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
− compiler/ghci/ByteCodeItbls.hs 
@@ -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 GHC.Types.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)
− compiler/ghci/ByteCodeLink.hs 
@@ -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-    ]
− compiler/ghci/Debugger.hs 
@@ -1,237 +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 GHC.Iface.Syntax ( showToHeader )-import GHC.Iface.Env    ( 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"-                                 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-         `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
− compiler/ghci/GHCi.hs 
@@ -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<n>) 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
− compiler/ghci/Linker.hs 
@@ -1,1707 +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 GHC.Iface.Load-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-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)-                                                    , Option "-Xlinker"-                                                    , Option "-rpath"-                                                    , Option "-Xlinker"-                                                    , Option lp ])-                                     (nub $ fst <$> temp_sos)-                        ++ concatMap-                             (\lp ->-                                 [ Option ("-L" ++ lp)-                                 , Option "-Xlinker"-                                 , Option "-rpath"-                                 , Option "-Xlinker"-                                 , Option lp-                                 ])-                             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-      | dynamicGhc = return ()-        -- We don't do any cleanup when linking objects with the-        -- dynamic linker.  Doing so introduces extra complexity for-        -- not much benefit.--      -- Code unloading currently disabled due to instability.-      -- See #16841.-      -- id False, so that the pattern-match checker doesn't complain-      | id False -- 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)-      | otherwise = return () -- see #16841--{- **********************************************************************--                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 -> UnitInfo -> 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-        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--        -- 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 -> UnitInfo -> 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.-    ---  = findDll   user `orElse`-    tryImpLib user `orElse`-    findDll   gcc  `orElse`-    findSysDll     `orElse`-    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-                     in apply $ short : full : map gcc files-     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)---- 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-        ; mb_fwk <- findFile ps fwk_file-        ; case mb_fwk of-            Just fwk_path -> loadDLL hsc_env fwk_path-            Nothing       -> return (Just "not found") }-                -- Tried all our known library paths, but dlopen()-                -- has no built-in paths for frameworks: give up-   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"]--{- **********************************************************************--                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")
− compiler/ghci/RtClosureInspect.hs 
@@ -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 GHC.Types.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 GHC.Iface.Env-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 GHC.Runtime.Layout ( 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("<function>")-  | 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 "<stablePtr>"-    | t == stableNamePrimTyCon       = text "<stableName>"-    | t == statePrimTyCon            = text "<statethread>"-    | t == proxyPrimTyCon            = text "<proxy>"-    | t == realWorldTyCon            = text "<realworld>"-    | t == threadIdPrimTyCon         = text "<ThreadId>"-    | t == weakPrimTyCon             = text "<Weak>"-    | t == arrayPrimTyCon            = text "<array>"-    | t == smallArrayPrimTyCon       = text "<smallArray>"-    | t == byteArrayPrimTyCon        = text "<bytearray>"-    | t == mutableArrayPrimTyCon     = text "<mutableArray>"-    | t == smallMutableArrayPrimTyCon = text "<smallMutableArray>"-    | t == mutableByteArrayPrimTyCon = text "<mutableByteArray>"-    | t == mutVarPrimTyCon           = text "<mutVar>"-    | t == mVarPrimTyCon             = text "<mVar>"-    | t == tVarPrimTyCon             = text "<tVar>"-    | 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:--  <datacon reptype>  =  <actual heap contents>--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 <base_type> <rtti_type>--- 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
compiler/iface/BuildTyCl.hs view
@@ -38,7 +38,7 @@ import TcType  import SrcLoc( SrcSpan, noSrcSpan )-import DynFlags+import GHC.Driver.Session import TcRnMonad import UniqSupply import Util
compiler/iface/FlagChecker.hs view
@@ -11,8 +11,8 @@ import GhcPrelude  import Binary-import DynFlags-import HscTypes+import GHC.Driver.Session+import GHC.Driver.Types import Module import Name import Fingerprint
− compiler/llvmGen/Llvm.hs 
@@ -1,64 +0,0 @@--- ------------------------------------------------------------------------------- | This module supplies bindings to generate Llvm IR from Haskell--- (<http://www.llvm.org/docs/LangRef.html>).------ 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 (<http://www.cs.uu.nl/wiki/Ehc/WebHome>).-----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-
− compiler/llvmGen/Llvm/AbsSyn.hs 
@@ -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)-
− compiler/llvmGen/Llvm/MetaData.hs 
@@ -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 = !{ [<metadata expressions>] !}------ * 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 = !{ [!<n>] }' form).-    = MetaNamed !LMString [MetaId]-    -- | Metadata node declaration.-    -- ('!0 = metadata !{ <metadata expression> }' form).-    | MetaUnnamed !MetaId !MetaExpr
− compiler/llvmGen/Llvm/PpLlvm.hs 
@@ -1,499 +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 = hsep $ punctuate comma $ map ppCallMetaExpr 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--        -- Metadata needs to be marked as having the `metadata` type when used-        -- in a call argument-        ppCallMetaExpr (MetaVar v) = ppr 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 '!'
− compiler/llvmGen/Llvm/Types.hs 
@@ -1,888 +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 (LMLitVar x)  = ppr x-  ppr (x         )  = ppr (getVarType x) <+> 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 l@(LMVectorLit {}) = ppLit l-  ppr l                  = ppr (getLitType l) <+> 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 <http://llvm.org/docs/LangRef.html#fnattrs>-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 <http://www.llvm.org/docs/LangRef.html#linkage>, 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)
− compiler/llvmGen/LlvmCodeGen.hs 
@@ -1,216 +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 GHC.Cmm-import GHC.Cmm.Dataflow.Collections-import GHC.Cmm.Ppr--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 supportedLlvmVersion) <> " 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)--       -- run code generation-       a <- runLlvm dflags (fromMaybe supportedLlvmVersion mb_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"-      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 ]-  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 <var> 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], [])
− compiler/llvmGen/LlvmCodeGen/Base.hs 
@@ -1,685 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveFunctor #-}--{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}---- ------------------------------------------------------------------------------- | Base LLVM Code Generation module------ Contains functions useful through out the code generator.-----module LlvmCodeGen.Base (--        LlvmCmmDecl, LlvmBasicBlock,-        LiveGlobalRegs,-        LlvmUnresData, LlvmData, UnresLabel, UnresStatic,--        LlvmVersion, supportedLlvmVersion, llvmVersionSupported, parseLlvmVersion,-        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, padLiveArgs, isFPR,--        strCLabel_llvm, strDisplayName_llvm, strProcedureName_llvm,-        getGlobalPtr, generateExternDecls,--        aliasify, llvmDefLabel-    ) where--#include "HsVersions.h"-#include "ghcautoconf.h"--import GhcPrelude--import Llvm-import LlvmCodeGen.Regs--import GHC.Cmm.CLabel-import GHC.Platform.Regs ( activeStgRegs )-import DynFlags-import FastString-import GHC.Cmm              hiding ( succ )-import GHC.Cmm.Utils (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 (sort, groupBy, intercalate)-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 platform = targetPlatform dflags-          allRegs = activeStgRegs platform-          paddedLive = map (\(_,r) -> r) $ padLiveArgs dflags live-          isLive r = r `elem` alwaysLive || r `elem` paddedLive-          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--sameFPRClass :: GlobalReg -> GlobalReg -> Bool-sameFPRClass (FloatReg _)  (FloatReg _) = True-sameFPRClass (DoubleReg _) (DoubleReg _) = True-sameFPRClass (XmmReg _)    (XmmReg _) = True-sameFPRClass (YmmReg _)    (YmmReg _) = True-sameFPRClass (ZmmReg _)    (ZmmReg _) = True-sameFPRClass _             _          = False--normalizeFPRNum :: GlobalReg -> GlobalReg-normalizeFPRNum (FloatReg _)  = FloatReg 1-normalizeFPRNum (DoubleReg _) = DoubleReg 1-normalizeFPRNum (XmmReg _)    = XmmReg 1-normalizeFPRNum (YmmReg _)    = YmmReg 1-normalizeFPRNum (ZmmReg _)    = ZmmReg 1-normalizeFPRNum _ = error "normalizeFPRNum expected only FPR regs"--getFPRCtor :: GlobalReg -> Int -> GlobalReg-getFPRCtor (FloatReg _)  = FloatReg-getFPRCtor (DoubleReg _) = DoubleReg-getFPRCtor (XmmReg _)    = XmmReg-getFPRCtor (YmmReg _)    = YmmReg-getFPRCtor (ZmmReg _)    = ZmmReg-getFPRCtor _ = error "getFPRCtor expected only FPR regs"--fprRegNum :: GlobalReg -> Int-fprRegNum (FloatReg i)  = i-fprRegNum (DoubleReg i) = i-fprRegNum (XmmReg i)    = i-fprRegNum (YmmReg i)    = i-fprRegNum (ZmmReg i)    = i-fprRegNum _ = error "fprRegNum expected only FPR regs"---- | Input: dynflags, and the list of live registers------ Output: An augmented list of live registers, where padding was--- added to the list of registers to ensure the calling convention is--- correctly used by LLVM.------ Each global reg in the returned list is tagged with a bool, which--- indicates whether the global reg was added as padding, or was an original--- live register.------ That is, True => padding, False => a real, live global register.------ Also, the returned list is not sorted in any particular order.----padLiveArgs :: DynFlags -> LiveGlobalRegs -> [(Bool, GlobalReg)]-padLiveArgs dflags live =-      if platformUnregisterised plat-        then taggedLive -- not using GHC's register convention for platform.-        else padding ++ taggedLive-  where-    taggedLive = map (\x -> (False, x)) live-    plat = targetPlatform dflags--    fprLive = filter isFPR live-    padding = concatMap calcPad $ groupBy sharesClass fprLive--    sharesClass :: GlobalReg -> GlobalReg -> Bool-    sharesClass a b = sameFPRClass a b || overlappingClass-      where-        overlappingClass = regsOverlap dflags (norm a) (norm b)-        norm = CmmGlobal . normalizeFPRNum--    calcPad :: [GlobalReg] -> [(Bool, GlobalReg)]-    calcPad rs = getFPRPadding (getFPRCtor $ head rs) rs--getFPRPadding :: (Int -> GlobalReg) -> LiveGlobalRegs -> [(Bool, GlobalReg)]-getFPRPadding paddingCtor live = padding-    where-        fprRegNums = sort $ map fprRegNum live-        (_, padding) = foldl assignSlots (1, []) $ fprRegNums--        assignSlots (i, acc) regNum-            | i == regNum = -- don't need padding here-                  (i+1, acc)-            | i < regNum = let -- add padding for slots i .. regNum-1-                  numNeeded = regNum-i-                  acc' = genPad i numNeeded ++ acc-                in-                  (regNum+1, acc')-            | otherwise = error "padLiveArgs -- i > regNum ??"--        genPad start n =-            take n $ flip map (iterate (+1) start) (\i ->-                (True, paddingCtor i))----- | 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 to avoid using the Eq instance!-newtype LlvmVersion = LlvmVersion { llvmVersionNE :: NE.NonEmpty Int }--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 LLVM Version that is currently supported.-supportedLlvmVersion :: LlvmVersion-supportedLlvmVersion = LlvmVersion (sUPPORTED_LLVM_VERSION NE.:| [])--llvmVersionSupported :: LlvmVersion -> Bool-llvmVersionSupported (LlvmVersion v) = NE.head v == sUPPORTED_LLVM_VERSION--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 -> 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-    liftIO $ Outp.bufLeftRenderSDoc dflags out-               (Outp.mkCodeStyle Outp.CStyle) 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-    dflags <- getDynFlags-    mk "memcpy" i8Ptr [i8Ptr, i8Ptr, llvmWord dflags]-    mk "memmove" i8Ptr [i8Ptr, i8Ptr, llvmWord dflags]-    mk "memset" i8Ptr [i8Ptr, llvmWord dflags, llvmWord dflags]-    mk "newSpark" (llvmWord dflags) [i8Ptr, i8Ptr]-  where-    mk n ret args = do-      let n' = llvmDefLabel $ 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 -> 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 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@.
− compiler/llvmGen/LlvmCodeGen/CodeGen.hs 
@@ -1,1995 +0,0 @@-{-# LANGUAGE CPP, GADTs #-}-{-# OPTIONS_GHC -fno-warn-type-defaults #-}-{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}--- ------------------------------------------------------------------------------- | 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 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 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 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 <- 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--    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--    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--    -- parameter types-    let arg_type (_, AddrHint) = i8Ptr-        -- cast pointers to i8*. Llvm equivalent of void*-        arg_type (expr, _) = cmmToLlvmType $ cmmExprType dflags expr--    -- 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) ++ "."--    -- extract Cmm call convention, and translate to LLVM call convention-    platform <- lift $ getLlvmPlatform-    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.-    -}--    -- 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 = tysToParams $ map arg_type args_hints-    let funTy = \name -> LMFunction $ LlvmFunctionDecl name ExternallyVisible-                             lmconv retTy FixedArgs argTy (llvmFunAlign dflags)---    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<width>, but overflowBit is i1, so we need to cast (Cmm expects-    -- both to be i<width>)-    (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-                 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---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_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---- | 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 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--  dflags <- getDynFlags-  stmtss <- flip mapM 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--    -- the bool indicates whether the register is padding.-    let alwaysNeeded = map (\r -> (False, r)) alwaysLive-        livePadded = alwaysNeeded ++ 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)-    platform <- getDynFlag targetPlatform-    let allRegs = activeStgRegs platform-    loads <- flip mapM allRegs $ \r -> case () of-      _ | (False, r) `elem` livePadded-                             -> loadExpr r   -- if r is not padding, load it-        | not (isFPR r) || (True, r) `elem` livePadded-                             -> 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 :: 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---- | 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
− compiler/llvmGen/LlvmCodeGen/Data.hs 
@@ -1,196 +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 GHC.Cmm.BlockId-import GHC.Cmm.CLabel-import GHC.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 isSecConstant sec 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!"
− compiler/llvmGen/LlvmCodeGen/Ppr.hs 
@@ -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 GHC.Cmm.CLabel-import GHC.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"
− compiler/llvmGen/LlvmCodeGen/Regs.hs 
@@ -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 GHC.Cmm.Expr-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
− compiler/llvmGen/LlvmMangler.hs 
@@ -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
− compiler/main/CodeOutput.hs 
@@ -1,264 +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 GHC.CmmToC             ( writeC )-import GHC.Cmm.Lint          ( cmmLint )-import Packages-import GHC.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"-                      FormatC-                      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 <ffi.h>\n"-              | otherwise = ""--        stub_h_file_exists-           <- outputForeignStubs_help stub_h stub_h_output_w-                ("#include <HsFFI.h>\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 <Rts.h>\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
− compiler/main/DriverMkDepend.hs 
@@ -1,423 +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 )-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--                -- 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 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"-
− compiler/main/DriverPipeline.hs 
@@ -1,2341 +0,0 @@-{-# LANGUAGE CPP, NamedFieldPuns, NondecreasingIndentation, BangPatterns, MultiWayIf #-}--{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}------------------------------------------------------------------------------------- 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 <ghcplatform.h>-#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 GHC.Iface.Utils  ( 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, 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_mod_details = hmi_details,-                     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, details)) <- 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 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--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, ModDetails))-                                -- ^ (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, ModDetails))-                                -- ^ (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, 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_mod_details = mod_details,-                        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)-                    -- TODO(osa): ModIface and ModDetails need to be in sync,-                    -- but we only generate ModIface with the backend info. See-                    -- !2100 for more discussion on this. This will be fixed-                    -- with !1304 or !2100.-                    setIface final_iface mod_details--                    -- 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 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 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 gopt Opt_RPath dflags-                          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<some-                  -- dir> 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 &&-           gopt Opt_RPath dflags-            = 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,<sym> contained in other_flags-                 -- needs to be put before -l<package>,-                 -- 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 = if staticLink-                   then SysTools.runLibtool-                   else SysTools.runLink-    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-                               ArchARM64  -> 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-                          then [ "-Wl,-dead_strip_dylibs" ]-                          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 $-             "<?xml version=\"1.0\" encoding=\"UTF-8\" standalone=\"yes\"?>\n"++-             "  <assembly xmlns=\"urn:schemas-microsoft-com:asm.v1\" manifestVersion=\"1.0\">\n"++-             "  <assemblyIdentity version=\"1.0.0.0\"\n"++-             "     processorArchitecture=\"X86\"\n"++-             "     name=\"" ++ dropExtension exe_filename ++ "\"\n"++-             "     type=\"win32\"/>\n\n"++-             "  <trustInfo xmlns=\"urn:schemas-microsoft-com:asm.v3\">\n"++-             "    <security>\n"++-             "      <requestedPrivileges>\n"++-             "        <requestedExecutionLevel level=\"asInvoker\" uiAccess=\"false\"/>\n"++-             "        </requestedPrivileges>\n"++-             "       </security>\n"++-             "  </trustInfo>\n"++-             "</assembly>\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 (lookupUnit 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 :: [UnitInfo] -> 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.--}--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 cc = SysTools.runLink dflags ([-                       SysTools.Option "-nostdlib",-                       SysTools.Option "-Wl,-r"-                     ]-                        -- See Note [No PIE while linking] in DynFlags-                     ++ (if toolSettings_ccSupportsNoPie toolSettings'-                          then [SysTools.Option "-no-pie"]-                          else [])--                     ++ (if any (cc ==) [Clang, AppleClang, AppleClang51]-                          then []-                          else [SysTools.Option "-nodefaultlibs"])-                     ++ (if osInfo == OSFreeBSD-                          then [SysTools.Option "-L/usr/lib"]-                          else [])-                        -- gcc on sparc sets -Wl,--relax implicitly, but-                        -- -r and --relax are incompatible for ld, so-                        -- disable --relax explicitly.-                     ++ (if platformArch (targetPlatform dflags)-                                `elem` [ArchSPARC, ArchSPARC64]-                         && ldIsGnuLd-                            then [SysTools.Option "-Wl,-no-relax"]-                            else [])-                        -- See Note [Produce big objects on Windows]-                     ++ [ SysTools.Option "-Wl,--oformat,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' = ["-Wl,--build-id=none"]-                  | otherwise                     = []--  ccInfo <- getCompilerInfo dflags-  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] ccInfo-     else if toolSettings_ldSupportsFilelist toolSettings'-     then do-          filelist <- newTempName dflags TFL_CurrentModule "filelist"-          writeFile filelist $ unlines o_files-          ld_r [SysTools.Option "-Wl,-filelist",-                SysTools.FileOption "-Wl," filelist] ccInfo-     else do-          ld_r (map (SysTools.FileOption "") o_files) ccInfo---- -------------------------------------------------------------------------------- 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.--}
− compiler/main/DynamicLoading.hs 
@@ -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 GHC.Iface.Load   ( loadPluginInterface )-import RdrName          ( RdrName, ImportSpec(..), ImpDeclSpec(..)-                        , ImpItemSpec(..), mkGlobalRdrEnv, lookupGRE_RdrName-                        , gre_name, mkRdrQual )-import OccName          ( OccName, mkVarOcc )-import GHC.Rename.Names ( 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
compiler/main/Elf.hs view
@@ -18,7 +18,7 @@  import AsmUtils import Exception-import DynFlags+import GHC.Driver.Session import ErrUtils import Maybes     (MaybeT(..),runMaybeT) import Util       (charToC)
− compiler/main/Finder.hs 
@@ -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 '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( installedModuleUnitId mod == installedUnitInfoId pkg_conf, ppr (installedModuleUnitId mod) <+> ppr (installedUnitInfoId 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 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 dflags uid)-           in text "Perhaps you need to add" <+>-              quotes (ppr (packageName pkg)) <+>-              text "to the build-depends in your .cabal file."-     | Just pkg <- lookupUnit dflags uid-         = 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)
− compiler/main/GHC.hs 
@@ -1,1705 +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,-        interpretPackageEnv,--        -- * 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,-        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,--        -- *** 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 GHC.Iface.Load   ( 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 GHC.Iface.Tidy-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 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 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--import Maybes-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.-  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<size> 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--- <http://hackage.haskell.org/package/ghc-paths>.--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'' <- liftIO $ interpretPackageEnv 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--- 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--- '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-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 (unitInfoMap (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 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 '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@(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 = 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))--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)--    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"
− compiler/main/GhcMake.hs 
@@ -1,2723 +0,0 @@-{-# 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 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 GHC.IfaceToCore  ( 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 -> UnitInfo -> Bool-        matchingStr str p-                =  str == sourcePackageIdString p-                || str == packageNameString p--        matching :: DynFlags -> PackageArg -> UnitInfo -> 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 -> UnitInfo -> UnitId-        realUnitId dflags-          = unwireUnitId dflags-          . DefiniteUnitId-          . DefUnitId-          . installedUnitInfoId---- | 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 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 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 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, 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 probably 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 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 &&-                                 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 "<command line>")--        -- 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_ByteCode (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 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-          -> 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)))
− compiler/main/GhcPlugins.hs 
@@ -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 GHC.Iface.Env    ( 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
− compiler/main/HscMain.hs 
@@ -1,1937 +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', doCodeGen-    , 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 GHC.IfaceToCore  ( typecheckIface )-import TcRnMonad-import TcHsSyn          ( ZonkFlexi (DefaultFlexi) )-import NameCache        ( initNameCache )-import GHC.Iface.Load   ( ifaceStats, initExternalPackageState )-import PrelInfo-import GHC.Iface.Utils-import Desugar-import SimplCore-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 CostCentre-import ProfInit-import TyCon-import Name-import GHC.Cmm-import GHC.Cmm.Parser         ( parseCmmFile )-import GHC.Cmm.Info.Build-import GHC.Cmm.Pipeline-import GHC.Cmm.Info-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-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 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)-import GHC.Iface.Ext.Debug  ( 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"-                        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 "<built-in>" and "<command-line>"-            --   - 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"-                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--        -- 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, 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 <- finish mod_summary tc_result mb_old_hash-            return (status, 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-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-      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)--        return $ case (target, hsc_src) of-          (HscNothing, _) -> HscNotGeneratingCode iface details-          (_, HsBootFile) -> HscUpdateBoot iface details-          (_, HsigFile) -> HscUpdateSig iface details-          _ -> panic "finish"--  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_mod_details = details,-                             hscs_partial_iface = partial_iface,-                             hscs_old_iface_hash = mb_old_hash,-                             hscs_iface_dflags = dflags }-    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--- 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  -- [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)-                        $ mkErrMsg 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" #-}-                      lookupHook cmmToRawCmmHook-                        (\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, ())-                <- {-# 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" 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 = mkModule (thisPackage dflags) mod_name-        (_, cmmgroup) <- cmmPipeline hsc_env (emptySRT cmm_mod) cmm-        unless (null cmmgroup) $-          dumpIfSet_dyn dflags Opt_D_dump_cmm "Output Cmm"-            FormatCMM (ppr cmmgroup)-        rawCmms <- lookupHook cmmToRawCmmHook-                     (\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 -----------------------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" #-}-            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 =-          {-# SCC "cmmPipeline" #-}-          let run_pipeline = cmmPipeline hsc_env-          in void $ Stream.mapAccumL run_pipeline (emptySRT this_mod) ppr_stream1--        dump2 a = do-          unless (null a) $-            dumpIfSet_dyn dflags Opt_D_dump_cmm "Output Cmm" FormatCMM (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 "<interactive>" 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 "<interactive>" 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 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 "<interactive>" 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 { 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
− compiler/main/InteractiveEval.hs 
@@ -1,1271 +0,0 @@-{-# LANGUAGE CPP, MagicHash, NondecreasingIndentation,-    RecordWildCards, BangPatterns #-}--{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}---- ----------------------------------------------------------------------------------- (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 GHC.Iface.Env   ( newInteractiveBinder )-import FamInstEnv      ( FamInst )-import CoreFVs         ( orphNamesOfFamInst )-import TyCon-import Type             hiding( typeKind )-import GHC.Types.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 = "<interactive>"-  , 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 "<interactive>" 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)--#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 "<unknown>")-   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, "<exception thrown>")---- 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"-                   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 `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 "<interactive>") 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
− compiler/main/PprTyThing.hs 
@@ -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 GHC.Iface.Syntax ( ShowSub(..), ShowHowMuch(..), AltPpr(..)-  , showToHeader, pprIfaceDecl )-import CoAxiom ( coAxiomTyCon )-import HscTypes( tyThingParent_maybe )-import GHC.Iface.Utils ( 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 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.Utils.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-  = 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 "--"
compiler/main/StaticPtrTable.hs view
@@ -119,19 +119,19 @@ * 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').+  in upsweep after we have compiled the module (see GHC.Driver.Make.upsweep'). -}  import GhcPrelude  import GHC.Cmm.CLabel-import CoreSyn-import CoreUtils (collectMakeStaticArgs)+import GHC.Core+import GHC.Core.Utils (collectMakeStaticArgs) import DataCon-import DynFlags-import HscTypes+import GHC.Driver.Session+import GHC.Driver.Types import Id-import MkCore (mkStringExprFSWith)+import GHC.Core.Make (mkStringExprFSWith) import Module import Name import Outputable
compiler/main/SysTools.hs view
@@ -43,11 +43,11 @@ import GHC.Settings  import Module-import Packages+import GHC.Driver.Packages import Outputable import ErrUtils import GHC.Platform-import DynFlags+import GHC.Driver.Session  import Control.Monad.Trans.Except (runExceptT) import System.FilePath
compiler/main/SysTools/ExtraObj.hs view
@@ -15,8 +15,8 @@  import AsmUtils import ErrUtils-import DynFlags-import Packages+import GHC.Driver.Session+import GHC.Driver.Packages import GHC.Platform import Outputable import SrcLoc           ( noSrcSpan )
compiler/main/SysTools/Info.hs view
@@ -10,7 +10,7 @@  import Exception import ErrUtils-import DynFlags+import GHC.Driver.Session import Outputable import Util
compiler/main/SysTools/Process.hs view
@@ -12,7 +12,7 @@  import Exception import ErrUtils-import DynFlags+import GHC.Driver.Session import FastString import Outputable import Panic@@ -32,6 +32,19 @@  import FileCleanup +-- | Enable process jobs support on Windows if it can be expected to work (e.g.+-- @process >= 1.6.8.0@).+enableProcessJobs :: CreateProcess -> CreateProcess+#if defined(MIN_VERSION_process)+#if MIN_VERSION_process(1,6,8)+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'@@ -68,7 +81,7 @@     -> IO (ExitCode, String, String) -- ^ (exit_code, stdout, stderr) readProcessEnvWithExitCode prog args env_update = do     current_env <- getEnvironment-    readCreateProcessWithExitCode (proc prog args) {+    readCreateProcessWithExitCode (enableProcessJobs $ proc prog args) {         env = Just (replaceVar env_update current_env) } ""  -- Don't let gcc localize version info string, #8825@@ -220,8 +233,22 @@   -- 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+        -- 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
compiler/main/SysTools/Tasks.hs view
@@ -10,8 +10,8 @@  import Exception import ErrUtils-import HscTypes-import DynFlags+import GHC.Driver.Types+import GHC.Driver.Session import Outputable import GHC.Platform import Util@@ -22,7 +22,7 @@ import System.Process import GhcPrelude -import LlvmCodeGen.Base (LlvmVersion, llvmVersionStr, supportedLlvmVersion, parseLlvmVersion)+import GHC.CmmToLlvm.Base (LlvmVersion, llvmVersionStr, supportedLlvmVersion, parseLlvmVersion)  import SysTools.Process import SysTools.Info
+ compiler/main/UpdateCafInfos.hs view
@@ -0,0 +1,141 @@+{-# LANGUAGE CPP, BangPatterns, Strict, RecordWildCards #-}++module UpdateCafInfos+  ( updateModDetailsCafInfos+  ) where++import GhcPrelude++import GHC.Core+import GHC.Driver.Types+import Id+import IdInfo+import InstEnv+import NameEnv+import NameSet+import Util+import Var+import Outputable++#include "HsVersions.h"++-- | Update CafInfos of all occurences (in rules, unfoldings, class instances)+updateModDetailsCafInfos+  :: NameSet -- ^ Non-CAFFY names in the module. Names not in this set are CAFFY.+  -> ModDetails -- ^ ModDetails to update+  -> ModDetails+updateModDetailsCafInfos non_cafs mod_details =+  {- pprTrace "updateModDetailsCafInfos" (text "non_cafs:" <+> ppr non_cafs) $ -}+  let+    ModDetails{ md_types = type_env -- for unfoldings+              , md_insts = insts+              , md_rules = rules+              } = mod_details++    -- type TypeEnv = NameEnv TyThing+    ~type_env' = mapNameEnv (updateTyThingCafInfos type_env' non_cafs) type_env+    -- Not strict!++    !insts' = strictMap (updateInstCafInfos type_env' non_cafs) insts+    !rules' = strictMap (updateRuleCafInfos type_env') rules+  in+    mod_details{ md_types = type_env'+               , md_insts = insts'+               , md_rules = rules'+               }++--------------------------------------------------------------------------------+-- Rules+--------------------------------------------------------------------------------++updateRuleCafInfos :: TypeEnv -> CoreRule -> CoreRule+updateRuleCafInfos _ rule@BuiltinRule{} = rule+updateRuleCafInfos type_env Rule{ .. } = Rule { ru_rhs = updateGlobalIds type_env ru_rhs, .. }++--------------------------------------------------------------------------------+-- Instances+--------------------------------------------------------------------------------++updateInstCafInfos :: TypeEnv -> NameSet -> ClsInst -> ClsInst+updateInstCafInfos type_env non_cafs =+    updateClsInstDFun (updateIdUnfolding type_env . updateIdCafInfo non_cafs)++--------------------------------------------------------------------------------+-- TyThings+--------------------------------------------------------------------------------++updateTyThingCafInfos :: TypeEnv -> NameSet -> TyThing -> TyThing++updateTyThingCafInfos type_env non_cafs (AnId id) =+    AnId (updateIdUnfolding type_env (updateIdCafInfo non_cafs id))++updateTyThingCafInfos _ _ other = other -- AConLike, ATyCon, ACoAxiom++--------------------------------------------------------------------------------+-- Unfoldings+--------------------------------------------------------------------------------++updateIdUnfolding :: TypeEnv -> Id -> Id+updateIdUnfolding type_env id =+    case idUnfolding id of+      CoreUnfolding{ .. } ->+        setIdUnfolding id CoreUnfolding{ uf_tmpl = updateGlobalIds type_env uf_tmpl, .. }+      DFunUnfolding{ .. } ->+        setIdUnfolding id DFunUnfolding{ df_args = map (updateGlobalIds type_env) df_args, .. }+      _ -> id++--------------------------------------------------------------------------------+-- Expressions+--------------------------------------------------------------------------------++updateIdCafInfo :: NameSet -> Id -> Id+updateIdCafInfo non_cafs id+  | idName id `elemNameSet` non_cafs+  = -- pprTrace "updateIdCafInfo" (text "Marking" <+> ppr id <+> parens (ppr (idName id)) <+> text "as non-CAFFY") $+    id `setIdCafInfo` NoCafRefs+  | otherwise+  = id++--------------------------------------------------------------------------------++updateGlobalIds :: NameEnv TyThing -> CoreExpr -> CoreExpr+-- Update occurrences of GlobalIds as directed by 'env'+-- The 'env' maps a GlobalId to a version with accurate CAF info+-- (and in due course perhaps other back-end-related info)+updateGlobalIds env e = go env e+  where+    go_id :: NameEnv TyThing -> Id -> Id+    go_id env var =+      case lookupNameEnv env (varName var) of+        Nothing -> var+        Just (AnId id) -> id+        Just other -> pprPanic "UpdateCafInfos.updateGlobalIds" $+          text "Found a non-Id for Id Name" <+> ppr (varName var) $$+          nest 4 (text "Id:" <+> ppr var $$+                  text "TyThing:" <+> ppr other)++    go :: NameEnv TyThing -> CoreExpr -> CoreExpr+    go env (Var v) = Var (go_id env v)+    go _ e@Lit{} = e+    go env (App e1 e2) = App (go env e1) (go env e2)+    go env (Lam b e) = assertNotInNameEnv env [b] (Lam b (go env e))+    go env (Let bs e) = Let (go_binds env bs) (go env e)+    go env (Case e b ty alts) =+        assertNotInNameEnv env [b] (Case (go env e) b ty (map go_alt alts))+      where+         go_alt (k,bs,e) = assertNotInNameEnv env bs (k, bs, go env e)+    go env (Cast e c) = Cast (go env e) c+    go env (Tick t e) = Tick t (go env e)+    go _ e@Type{} = e+    go _ e@Coercion{} = e++    go_binds :: NameEnv TyThing -> CoreBind -> CoreBind+    go_binds env (NonRec b e) =+      assertNotInNameEnv env [b] (NonRec b (go env e))+    go_binds env (Rec prs) =+      assertNotInNameEnv env (map fst prs) (Rec (mapSnd (go env) prs))++-- In `updateGlobaLIds` Names of local binders should not shadow Name of+-- globals. This assertion is to check that.+assertNotInNameEnv :: NameEnv a -> [Id] -> b -> b+assertNotInNameEnv env ids x = ASSERT(not (any (\id -> elemNameEnv (idName id) env) ids)) x
− compiler/nativeGen/AsmCodeGen.hs 
@@ -1,1234 +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--{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}--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 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 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"-      ArchARM64     -> 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"-                  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-        printSDocLn Pretty.LeftMode dflags h (mkCodeStyle AsmStyle)-                $ makeImportsDoc dflags (concat (ngs_imports ngs))-        return us'-  where-    dump_stats = dumpAction dflags (mkDumpStyle dflags 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 Debug.-              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--        {-# SCC "pprNativeCode" #-} bufLeftRenderSDoc dflags h-                                      (mkCodeStyle AsmStyle) 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 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" 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 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"-                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 (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"-                        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 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"-                        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 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"-                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 (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"-                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 "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
− compiler/nativeGen/BlockLayout.hs 
@@ -1,895 +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 GHC.Cmm.BlockId-import GHC.Cmm-import GHC.Cmm.Dataflow.Collections-import GHC.Cmm.Dataflow.Label--import DynFlags (gopt, GeneralFlag(..), DynFlags, backendMaintainsCfg)-import UniqFM-import Util-import Unique--import Digraph-import Outputable-import Maybes---- DEBUGGING ONLY---import GHC.Cmm.DebugBlock---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 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:-    <infoTable>-    B: goto C:-    <infoTable>-    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.-    <info table>-    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.---}----- | 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-    = -- 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-            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 small if we jump over an info table-                = Just (CfgEdge from to edgeInfo { edgeWeight = w/8 })-                | otherwise-                = Just edge--        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 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)
− compiler/nativeGen/CFG.hs 
@@ -1,1320 +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 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 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 GHC.Cmm.DebugBlock---import OrdList---import GHC.Cmm.DebugBlock.Trace-import GHC.Cmm.Ppr () -- For Outputable instances-import qualified DynFlags as D--import Data.List-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 <edgeData>)--- 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. (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 laid 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 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 :: 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 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
− compiler/nativeGen/CPrim.hs 
@@ -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 GHC.Cmm.Type-import GHC.Cmm.MachOp-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)
− compiler/nativeGen/Dwarf.hs 
@@ -1,269 +0,0 @@-module Dwarf (-  dwarfGen-  ) where--import GhcPrelude--import GHC.Cmm.CLabel-import GHC.Cmm.Expr    ( GlobalReg(..) )-import Config          ( cProjectName, cProjectVersion )-import CoreSyn         ( Tickish(..) )-import GHC.Cmm.DebugBlock-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 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--  -- 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-    ]
− compiler/nativeGen/Dwarf/Constants.hs 
@@ -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!"
− compiler/nativeGen/Dwarf/Types.hs 
@@ -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 GHC.Cmm.DebugBlock-import GHC.Cmm.CLabel-import GHC.Cmm.Expr         ( 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 establishes 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
− compiler/nativeGen/Format.hs 
@@ -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 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 Format (-    Format(..),-    intFormat,-    floatFormat,-    isFloatFormat,-    cmmTypeFormat,-    formatToWidth,-    formatInBytes-)--where--import GhcPrelude--import GHC.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
− compiler/nativeGen/Instruction.hs 
@@ -1,202 +0,0 @@--module Instruction (-        RegUsage(..),-        noUsage,-        GenBasicBlock(..), blockId,-        ListGraph(..),-        NatCmm,-        NatCmmDecl,-        NatBasicBlock,-        topInfoTable,-        entryBlocks,-        Instruction(..)-)--where--import GhcPrelude--import Reg--import GHC.Cmm.BlockId-import GHC.Cmm.Dataflow.Collections-import GHC.Cmm.Dataflow.Label-import DynFlags-import GHC.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]
− compiler/nativeGen/NCGMonad.hs 
@@ -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 GHC.Cmm.BlockId-import GHC.Cmm.Dataflow.Collections-import GHC.Cmm.Dataflow.Label-import GHC.Cmm.CLabel           ( CLabel )-import GHC.Cmm.DebugBlock-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 GHC.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; <block_l1>`-    -- 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 "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-        = 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)
− compiler/nativeGen/PIC.hs 
@@ -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 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 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 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 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 similar 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------ 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--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"-
− compiler/nativeGen/PPC/CodeGen.hs 
@@ -1,2453 +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 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---- 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 architectures, 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 ('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' _ (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<b) goto again2-                                   , CMPL fmt rhat (RIReg b)-                                   , BCC LTT again2 Nothing-                                   , BCC ALWAYS endif2 Nothing--                                   , NEWBLOCK endif2-                                     -- compute remainder-                                     -- r = (un21*b + un0 - q0*v) >> 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 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 = 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_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 :: 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
− compiler/nativeGen/PPC/Cond.hs 
@@ -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
− compiler/nativeGen/PPC/Instr.hs 
@@ -1,713 +0,0 @@-{-# LANGUAGE CPP #-}--{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}------------------------------------------------------------------------------------- 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 GHC.Cmm.BlockId-import GHC.Cmm.Dataflow.Collections-import GHC.Cmm.Dataflow.Label-import DynFlags-import GHC.Cmm-import GHC.Cmm.Info-import FastString-import GHC.Cmm.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
− compiler/nativeGen/PPC/Ppr.hs 
@@ -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 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 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.-            -- 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-    ]--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
− compiler/nativeGen/PPC/RegInfo.hs 
@@ -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 GHC.Cmm.BlockId-import GHC.Cmm-import GHC.Cmm.CLabel--import Unique-import Outputable (ppr, text, Outputable, (<>))--data JumpDest = DestBlockId BlockId---- Debug Instance-instance Outputable JumpDest where-  ppr (DestBlockId bid) = text "jd<blk>:" <> 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
− compiler/nativeGen/PPC/Regs.hs 
@@ -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 GHC.Cmm-import GHC.Cmm.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"
− compiler/nativeGen/PprBase.hs 
@@ -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 GHC.Cmm.CLabel-import GHC.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"
− compiler/nativeGen/RegAlloc/Graph/ArchBase.hs 
@@ -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]
− compiler/nativeGen/RegAlloc/Graph/ArchX86.hs 
@@ -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)-
− compiler/nativeGen/RegAlloc/Graph/Coalesce.hs 
@@ -1,99 +0,0 @@--- | Register coalescing.-module RegAlloc.Graph.Coalesce (-        regCoalesce,-        slurpJoinMovs-) where-import GhcPrelude--import RegAlloc.Liveness-import Instruction-import Reg--import GHC.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-
− compiler/nativeGen/RegAlloc/Graph/Main.hs 
@@ -1,472 +0,0 @@-{-# LANGUAGE CPP #-}-{-# 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 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)-        => 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--#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
− compiler/nativeGen/RegAlloc/Graph/Spill.hs 
@@ -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 GHC.Cmm hiding (RegSet)-import GHC.Cmm.BlockId-import GHC.Cmm.Dataflow.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 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, 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))
− compiler/nativeGen/RegAlloc/Graph/SpillClean.hs 
@@ -1,616 +0,0 @@-{-# LANGUAGE CPP #-}---- | 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 GHC.Cmm.BlockId-import GHC.Cmm-import UniqSet-import UniqFM-import Unique-import State-import 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 [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 (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
− compiler/nativeGen/RegAlloc/Graph/SpillCost.hs 
@@ -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 GHC.Cmm.Dataflow.Collections (mapLookup)-import GHC.Cmm.Dataflow.Label-import GHC.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 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 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 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) ]-
− compiler/nativeGen/RegAlloc/Graph/Stats.hs 
@@ -1,346 +0,0 @@-{-# LANGUAGE BangPatterns, CPP #-}--{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}---- | 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)-
− compiler/nativeGen/RegAlloc/Graph/TrivColorable.hs 
@@ -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 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"-                            ArchARM64     -> panic "trivColorable ArchARM64"-                            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"-                            ArchARM64     -> panic "trivColorable ArchARM64"-                            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"-                            ArchARM64     -> panic "trivColorable ArchARM64"-                            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--}
− compiler/nativeGen/RegAlloc/Linear/Base.hs 
@@ -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 GHC.Cmm.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)] }--
− compiler/nativeGen/RegAlloc/Linear/FreeRegs.hs 
@@ -1,89 +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"-                ArchARM64     -> panic "maxSpillSlots ArchARM64"-                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"-
− compiler/nativeGen/RegAlloc/Linear/JoinToTargets.hs 
@@ -1,378 +0,0 @@-{-# 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 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 GHC.Cmm.BlockId-import GHC.Cmm.Dataflow.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.")-
− compiler/nativeGen/RegAlloc/Linear/Main.hs 
@@ -1,920 +0,0 @@-{-# LANGUAGE BangPatterns, CPP, ScopedTypeVariables #-}--{-# 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 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 GHC.Cmm.BlockId-import GHC.Cmm.Dataflow.Collections-import GHC.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"-      ArchARM64      -> panic "linearRegAlloc ArchARM64"-      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 GHC.Cmm.Pipeline 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-
− compiler/nativeGen/RegAlloc/Linear/PPC/FreeRegs.hs 
@@ -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"
− compiler/nativeGen/RegAlloc/Linear/SPARC/FreeRegs.hs 
@@ -1,189 +0,0 @@-{-# LANGUAGE CPP #-}---- | 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-#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"
− compiler/nativeGen/RegAlloc/Linear/StackMap.hs 
@@ -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-
− compiler/nativeGen/RegAlloc/Linear/State.hs 
@@ -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 GHC.Cmm.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 }) ()
− compiler/nativeGen/RegAlloc/Linear/Stats.hs 
@@ -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 "")-
− compiler/nativeGen/RegAlloc/Linear/X86/FreeRegs.hs 
@@ -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"-
− compiler/nativeGen/RegAlloc/Linear/X86_64/FreeRegs.hs 
@@ -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"--
− compiler/nativeGen/RegAlloc/Liveness.hs 
@@ -1,1025 +0,0 @@-{-# 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 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 GHC.Cmm.BlockId-import CFG-import GHC.Cmm.Dataflow.Collections-import GHC.Cmm.Dataflow.Label-import GHC.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]
− compiler/nativeGen/SPARC/AddrMode.hs 
@@ -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
− compiler/nativeGen/SPARC/Base.hs 
@@ -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")--
− compiler/nativeGen/SPARC/CodeGen.hs 
@@ -1,700 +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 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 PIC-import Reg-import GHC.Cmm.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_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")-
− compiler/nativeGen/SPARC/CodeGen/Amode.hs 
@@ -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 GHC.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)
− compiler/nativeGen/SPARC/CodeGen/Base.hs 
@@ -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 GHC.Cmm-import GHC.Cmm.Ppr.Expr () -- 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"
− compiler/nativeGen/SPARC/CodeGen/CondCode.hs 
@@ -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 GHC.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)
− compiler/nativeGen/SPARC/CodeGen/Expand.hs 
@@ -1,156 +0,0 @@-{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}---- | 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 GHC.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 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)
− compiler/nativeGen/SPARC/CodeGen/Gen32.hs 
@@ -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 GHC.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)
− compiler/nativeGen/SPARC/CodeGen/Gen32.hs-boot 
@@ -1,16 +0,0 @@--module SPARC.CodeGen.Gen32 (-        getSomeReg,-        getRegister-)--where--import SPARC.CodeGen.Base-import NCGMonad-import Reg--import GHC.Cmm--getSomeReg  :: CmmExpr -> NatM (Reg, InstrBlock)-getRegister :: CmmExpr -> NatM Register
− compiler/nativeGen/SPARC/CodeGen/Gen64.hs 
@@ -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 GHC.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)
− compiler/nativeGen/SPARC/CodeGen/Sanity.hs 
@@ -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 GHC.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
− compiler/nativeGen/SPARC/Cond.hs 
@@ -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
− compiler/nativeGen/SPARC/Imm.hs 
@@ -1,67 +0,0 @@-module SPARC.Imm (-        -- immediate values-        Imm(..),-        strImmLit,-        litToImm-)--where--import GhcPrelude--import GHC.Cmm-import GHC.Cmm.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"
− compiler/nativeGen/SPARC/Instr.hs 
@@ -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 GHC.Cmm.CLabel-import GHC.Platform.Regs-import GHC.Cmm.BlockId-import DynFlags-import GHC.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.
− compiler/nativeGen/SPARC/Ppr.hs 
@@ -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 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 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"
− compiler/nativeGen/SPARC/Regs.hs 
@@ -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"
− compiler/nativeGen/SPARC/ShortcutJump.hs 
@@ -1,74 +0,0 @@-module SPARC.ShortcutJump (-        JumpDest(..), getJumpDestBlockId,-        canShortcut,-        shortcutJump,-        shortcutStatics,-        shortBlockId-)--where--import GhcPrelude--import SPARC.Instr-import SPARC.Imm--import GHC.Cmm.CLabel-import GHC.Cmm.BlockId-import GHC.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"
− compiler/nativeGen/SPARC/Stack.hs 
@@ -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
− compiler/nativeGen/TargetReg.hs 
@@ -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"-      ArchARM64     -> panic "targetVirtualRegSqueeze ArchARM64"-      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"-      ArchARM64     -> panic "targetRealRegSqueeze ArchARM64"-      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"-      ArchARM64     -> panic "targetClassOfRealReg ArchARM64"-      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"-      ArchARM64     -> panic "targetMkVirtualReg ArchARM64"-      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"-      ArchARM64     -> panic "targetRegDotColor ArchARM64"-      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
− compiler/nativeGen/X86/CodeGen.hs 
@@ -1,3743 +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--{-# 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 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 GHC.Cmm.DebugBlock            ( 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 GHC.Cmm.BlockId-import Module           ( 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 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.-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 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 -> 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).-    -}-    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 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-  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.--}---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-genCondBranch' is32Bit _bid true false (CmmMachOp mop [e1,e2])-  | is32Bit, Just W64 <- maybeIntComparison mop = do-  ChildCode64 code1 r1_lo <- iselExpr64 e1-  ChildCode64 code2 r2_lo <- iselExpr64 e2-  let r1_hi = getHiVRegFromLo r1_lo-      r2_hi = getHiVRegFromLo r2_lo-      cond = machOpToCond mop-      Just cond' = maybeFlipCond cond-  --TODO: Update CFG for x86-  let code = code1 `appOL` code2 `appOL` toOL [-        CMP II32 (OpReg r2_hi) (OpReg r1_hi),-        JXX cond true,-        JXX cond' false,-        CMP II32 (OpReg r2_lo) (OpReg r1_lo),-        JXX cond true] `appOL` genBranch false-  return code--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:-        <instrs>-    _B1:-        ...-        cmpxchgq ...-        jne _B1-        <instrs>-        <end _B1>-    _B2:-        ...-        cmpxchgq ...-        jne _B2-        <instrs>-        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:-        <instrs>-    _B1:-        ...-        cmpxchgq ...-        jne _B1-        jmp _B1'-    _B1':-        <instrs>-        <end _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)-            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)-            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)-            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)-    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)-    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"-    (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"--    _ -> if is32Bit-         then genCCall32' dflags target dest_regs args-         else genCCall64' dflags target dest_regs args--  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 [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)--      -- 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_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")---- -------------------------------------------------------------------------------- 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.<function we're in> 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 <II32-----------------------------------------------------------------------------------coerceFP2Int :: Width -> 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 <II32------------------------------------------------------------------------------------coerceFP2FP :: Width -> 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 [] = []
− compiler/nativeGen/X86/Cond.hs 
@@ -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-        | GE-        | GEU-        | GTT-        | GU-        | LE-        | LEU-        | LTT-        | LU-        | NE-        | NEG-        | POS-        | CARRY-        | OFLO-        | PARITY-        | NOTPARITY-        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
− compiler/nativeGen/X86/Instr.hs 
@@ -1,1054 +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 GHC.Cmm.BlockId-import GHC.Cmm.Dataflow.Collections-import GHC.Cmm.Dataflow.Label-import GHC.Platform.Regs-import GHC.Cmm-import FastString-import Outputable-import GHC.Platform--import BasicTypes       (Alignment)-import GHC.Cmm.CLabel-import DynFlags-import UniqSet-import Unique-import UniqSupply-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, 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 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:------    <info table>---    L:---       <code>------ becomes------    <info table>---    L:---       subl $rsp, N---       jmp Lnew---    Lnew:---       <code>------ 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<blk>:" <> ppr bid-  ppr (DestImm _imm)    = text "jd<imm>: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
− compiler/nativeGen/X86/Ppr.hs 
@@ -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 GHC.Cmm.Dataflow.Collections-import GHC.Cmm.Dataflow.Label-import BasicTypes       (Alignment, mkAlignment, alignmentBytes)-import DynFlags-import GHC.Cmm              hiding (topInfoTable)-import GHC.Cmm.BlockId-import GHC.Cmm.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--- <https://developer.apple.com/library/mac/documentation/DeveloperTools/Reference/Assembler/040-Assembler_Directives/asm_directives.html#//apple_ref/doc/uid/TP30000823-TPXREF101>--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:-    ```-      <info table data>-    label_info:-      <info table code>-    ```-    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]
− compiler/nativeGen/X86/RegInfo.hs 
@@ -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"]--
− compiler/nativeGen/X86/Regs.hs 
@@ -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 GHC.Cmm-import GHC.Cmm.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)-
compiler/prelude/PrelInfo.hs view
@@ -65,7 +65,7 @@ import Outputable import TysPrim import TysWiredIn-import HscTypes+import GHC.Driver.Types import Class import TyCon import UniqFM
compiler/prelude/THNames.hs view
@@ -24,7 +24,7 @@  templateHaskellNames :: [Name] -- The names that are implicitly mentioned by ``bracket''--- Should stay in sync with the import list of DsMeta+-- Should stay in sync with the import list of GHC.HsToCore.Quote  templateHaskellNames = [     returnQName, bindQName, sequenceQName, newNameName, liftName, liftTypedName,@@ -562,7 +562,7 @@ typeQTyConName          = libTc (fsLit "TypeQ")          typeQTyConKey patQTyConName           = libTc (fsLit "PatQ")           patQTyConKey --- These are used in DsMeta but always wrapped in a type variable+-- 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
compiler/profiling/ProfInit.hs view
@@ -12,7 +12,7 @@  import GHC.Cmm.CLabel import CostCentre-import DynFlags+import GHC.Driver.Session import Outputable import Module
compiler/simplCore/CSE.hs view
@@ -15,22 +15,22 @@  import GhcPrelude -import CoreSubst+import GHC.Core.Subst 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+import GHC.Core.Utils        ( mkAltExpr, eqExpr                         , exprIsTickedString                         , stripTicksE, stripTicksT, mkTicks )-import CoreFVs          ( exprFreeVars )+import GHC.Core.FVs          ( exprFreeVars ) import Type             ( tyConAppArgs )-import CoreSyn+import GHC.Core import Outputable import BasicTypes-import CoreMap+import GHC.Core.Map import Util             ( filterOut ) import Data.List        ( mapAccumL ) @@ -271,7 +271,7 @@    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+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@@ -416,7 +416,7 @@ -- 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.+-- 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)@@ -469,7 +469,7 @@  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.+[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:
compiler/simplCore/CallArity.hs view
@@ -11,13 +11,13 @@  import VarSet import VarEnv-import DynFlags ( DynFlags )+import GHC.Driver.Session ( DynFlags )  import BasicTypes-import CoreSyn+import GHC.Core import Id-import CoreArity ( typeArity )-import CoreUtils ( exprIsCheap, exprIsTrivial )+import GHC.Core.Arity ( typeArity )+import GHC.Core.Utils ( exprIsCheap, exprIsTrivial ) import UnVarGraph import Demand import Util@@ -384,7 +384,7 @@  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).+    [exprArity invariant] in GHC.Core.Arity).      If we are not doing that, a too-high arity annotation will be stored with     the id, confusing the simplifier later on.@@ -701,7 +701,7 @@   where     max_arity_by_type = length (typeArity (idType v))     max_arity_by_strsig-        | isBotRes result_info = length demands+        | isBotDiv result_info = length demands         | otherwise = a      (demands, result_info) = splitStrictSig (idStrictness v)
compiler/simplCore/Exitify.hs view
@@ -39,13 +39,13 @@ import Var import Id import IdInfo-import CoreSyn-import CoreUtils+import GHC.Core+import GHC.Core.Utils import State import Unique import VarSet import VarEnv-import CoreFVs+import GHC.Core.FVs import FastString import Type import Util( mapSnd )
compiler/simplCore/FloatIn.hs view
@@ -22,18 +22,18 @@  import GhcPrelude -import CoreSyn-import MkCore hiding    ( wrapFloats )-import HscTypes         ( ModGuts(..) )-import CoreUtils-import CoreFVs+import GHC.Core+import GHC.Core.Make hiding ( wrapFloats )+import GHC.Driver.Types     ( ModGuts(..) )+import GHC.Core.Utils+import GHC.Core.FVs import CoreMonad        ( CoreM ) import Id               ( isOneShotBndr, idType, isJoinId, isJoinId_maybe ) import Var import Type import VarSet import Util-import DynFlags+import GHC.Driver.Session import Outputable -- import Data.List        ( mapAccumL ) import BasicTypes       ( RecFlag(..), isRec )
compiler/simplCore/FloatOut.hs view
@@ -12,13 +12,13 @@  import GhcPrelude -import CoreSyn-import CoreUtils-import MkCore-import CoreArity        ( etaExpand )+import GHC.Core+import GHC.Core.Utils+import GHC.Core.Make+import GHC.Core.Arity   ( etaExpand ) import CoreMonad        ( FloatOutSwitches(..) ) -import DynFlags+import GHC.Driver.Session import ErrUtils         ( dumpIfSet_dyn, DumpFormat (..) ) import Id               ( Id, idArity, idType, isBottomingId,                           isJoinId, isJoinId_maybe )@@ -111,7 +111,7 @@ 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+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 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
compiler/simplCore/LiberateCase.hs view
@@ -11,9 +11,9 @@  import GhcPrelude -import DynFlags-import CoreSyn-import CoreUnfold       ( couldBeSmallEnoughToInline )+import GHC.Driver.Session+import GHC.Core+import GHC.Core.Unfold  ( couldBeSmallEnoughToInline ) import TysWiredIn       ( unitDataConId ) import Id import VarEnv
compiler/simplCore/SAT.hs view
@@ -54,8 +54,8 @@ import GhcPrelude  import Var-import CoreSyn-import CoreUtils+import GHC.Core+import GHC.Core.Utils import Type import Coercion import Id@@ -69,7 +69,7 @@ import UniqSet import Outputable -import Data.List+import Data.List (mapAccumL) import FastString  #include "HsVersions.h"
compiler/simplCore/SetLevels.hs view
@@ -66,18 +66,18 @@  import GhcPrelude -import CoreSyn+import GHC.Core import CoreMonad        ( FloatOutSwitches(..) )-import CoreUtils        ( exprType, exprIsHNF+import GHC.Core.Utils   ( exprType, exprIsHNF                         , exprOkForSpeculation                         , exprIsTopLevelBindable                         , isExprLevPoly                         , collectMakeStaticArgs                         )-import CoreArity        ( exprBotStrictness_maybe )-import CoreFVs          -- all of it-import CoreSubst-import MkCore           ( sortQuantVars )+import GHC.Core.Arity   ( exprBotStrictness_maybe )+import GHC.Core.FVs     -- all of it+import GHC.Core.Subst+import GHC.Core.Make    ( sortQuantVars )  import Id import IdInfo@@ -88,6 +88,7 @@ import VarEnv import Literal          ( litIsTrivial ) import Demand           ( StrictSig, Demand, isStrictDmd, splitStrictSig, increaseStrictSigArity )+import Cpr              ( mkCprSig, botCpr ) import Name             ( getOccName, mkSystemVarName ) import OccName          ( occNameString ) import Type             ( Type, mkLamTypes, splitTyConApp_maybe, tyCoVarsOfType@@ -339,7 +340,7 @@ 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 (_, 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)@@ -521,7 +522,7 @@      - exrpIsHNF catches the key case of an evaluated variable       - exprOkForSpeculation is /false/ of an evaluated variable;-       See Note [exprOkForSpeculation and evaluated variables] in CoreUtils+       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@@ -601,7 +602,7 @@ -- the expression, so that it can itself be floated.  lvlMFE env _ (_, AnnType ty)-  = return (Type (CoreSubst.substTy (le_subst env) 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@@ -627,7 +628,7 @@                                -- See Note [Free join points]   || isExprLevPoly expr          -- We can't let-bind levity polymorphic expressions-         -- See Note [Levity polymorphism invariants] in CoreSyn+         -- See Note [Levity polymorphism invariants] in GHC.Core   || notWorthFloating expr abs_vars   || not float_me   =     -- Don't float it out@@ -983,6 +984,7 @@       Nothing           -> id       Just (arity, sig) -> id `setIdArity`      (arity + n_extra)                               `setIdStrictness` (increaseStrictSigArity n_extra sig)+                              `setIdCprInfo`    mkCprSig (arity + n_extra) botCpr  notWorthFloating :: CoreExpr -> [Var] -> Bool -- Returns True if the expression would be replaced by@@ -1005,18 +1007,17 @@     go (Tick t e) n  = not (tickishIsCode t) && go e n     go (Cast e _)  n = go e n     go (App e arg) n-       | Type {}     <- arg = go e n-       | Coercion {} <- arg = go e n-       | n==0               = False-       | is_triv arg        = go e (n-1)-       | otherwise          = False-    go _ _                  = False+       -- 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-    is_triv (App e (Coercion {})) = 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 @@ -1030,6 +1031,14 @@ 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] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -1322,7 +1331,7 @@     (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+-- 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') }@@ -1663,7 +1672,7 @@                              mkSysLocal (mkFastString str) uniq poly_ty                            where                              str     = "poly_" ++ occNameString (getOccName bndr)-                             poly_ty = mkLamTypes abs_vars (CoreSubst.substTy subst (idType 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,
compiler/simplCore/SimplCore.hs view
@@ -12,19 +12,19 @@  import GhcPrelude -import DynFlags-import CoreSyn-import HscTypes+import GHC.Driver.Session+import GHC.Core+import GHC.Driver.Types import CSE              ( cseProgram )-import Rules            ( mkRuleBase, unionRuleBase,+import GHC.Core.Rules   ( mkRuleBase, unionRuleBase,                           extendRuleBaseList, ruleCheckProgram, addRuleInfo,                           getRules )-import PprCore          ( pprCoreBindings, pprCoreExpr )+import GHC.Core.Ppr     ( pprCoreBindings, pprCoreExpr ) import OccurAnal        ( occurAnalysePgm, occurAnalyseExpr ) import IdInfo-import CoreStats        ( coreBindsSize, coreBindsStats, exprSize )-import CoreUtils        ( mkTicks, stripTicksTop )-import CoreLint         ( endPass, lintPassResult, dumpPassResult,+import GHC.Core.Stats   ( coreBindsSize, coreBindsStats, exprSize )+import GHC.Core.Utils   ( mkTicks, stripTicksTop )+import GHC.Core.Lint    ( endPass, lintPassResult, dumpPassResult,                           lintAnnots ) import Simplify         ( simplTopBinds, simplExpr, simplRules ) import SimplUtils       ( simplEnvForGHCi, activeRule, activeUnfolding )@@ -45,14 +45,15 @@ import Specialise       ( specProgram) import SpecConstr       ( specConstrProgram) import DmdAnal          ( dmdAnalProgram )+import CprAnal          ( cprAnalProgram ) import CallArity        ( callArityAnalProgram ) import Exitify          ( exitifyProgram ) import WorkWrap         ( wwTopBinds ) import SrcLoc import Util import Module-import Plugins          ( withPlugins, installCoreToDos )-import DynamicLoading  -- ( initializePlugins )+import GHC.Driver.Plugins ( withPlugins, installCoreToDos )+import GHC.Runtime.Loader -- ( initializePlugins )  import UniqSupply       ( UniqSupply, mkSplitUniqSupply, splitUniqSupply ) import UniqFM@@ -141,7 +142,7 @@     maybe_rule_check phase = runMaybe rule_check (CoreDoRuleCheck phase)      maybe_strictness_before phase-      = runWhen (phase `elem` strictnessBefore dflags) CoreDoStrictness+      = runWhen (phase `elem` strictnessBefore dflags) CoreDoDemand      base_mode = SimplMode { sm_phase      = panic "base_mode"                           , sm_names      = []@@ -168,21 +169,19 @@     simpl_gently = CoreDoSimplify max_iter                        (base_mode { sm_phase = InitialPhase                                   , sm_names = ["Gentle"]-                                  , sm_rules = rules_on   -- Note [RULEs enabled in SimplGently]+                                  , 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 -    strictness_pass = if ww_on-                       then [CoreDoStrictness,CoreDoWorkerWrapper]-                       else [CoreDoStrictness]+    dmd_cpr_ww = if ww_on then [CoreDoDemand,CoreDoCpr,CoreDoWorkerWrapper]+                          else [CoreDoDemand,CoreDoCpr]  -    -- New demand analyser     demand_analyser = (CoreDoPasses (-                           strictness_pass +++                           dmd_cpr_ww ++                            [simpl_phase 0 ["post-worker-wrapper"] max_iter]                            )) @@ -332,7 +331,7 @@         simpl_phase 0 ["final"] max_iter,          runWhen late_dmd_anal $ CoreDoPasses (-            strictness_pass +++            dmd_cpr_ww ++             [simpl_phase 0 ["post-late-ww"] max_iter]           ), @@ -341,7 +340,7 @@         -- 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,+        runWhen (strictness || late_dmd_anal) CoreDoDemand,          maybe_rule_check (Phase 0)      ]@@ -382,9 +381,10 @@    perf/compiler/T9872b.run           T9872b [stat too good] (normal)    perf/compiler/T9872d.run           T9872d [stat too good] (normal) -Note [RULEs enabled in SimplGently]+Note [RULEs enabled in InitialPhase] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-RULES are enabled when doing "gentle" simplification.  Two reasons:+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@@ -445,9 +445,12 @@ doCorePass CoreDoExitify             = {-# SCC "Exitify" #-}                                        doPass exitifyProgram -doCorePass CoreDoStrictness          = {-# SCC "NewStranal" #-}+doCorePass CoreDoDemand              = {-# SCC "DmdAnal" #-}                                        doPassDFM dmdAnalProgram +doCorePass CoreDoCpr                 = {-# SCC "CprAnal" #-}+                                       doPassDFM cprAnalProgram+ doCorePass CoreDoWorkerWrapper       = {-# SCC "WorkWrap" #-}                                        doPassDFU wwTopBinds @@ -555,23 +558,25 @@ ************************************************************************ -} -simplifyExpr :: DynFlags -- includes spec of what core-to-core passes to do+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------ Also used by Template Haskell-simplifyExpr dflags expr+simplifyExpr hsc_env expr   = withTiming dflags (text "Simplify [expr]") (const ()) $-    do  {-        ; us <-  mkSplitUniqSupply 's'+    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 emptyRuleEnv-                               emptyFamInstEnvs us sz-                               (simplExprGently (simplEnvForGHCi dflags) 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)@@ -582,6 +587,8 @@          ; return expr'         }+  where+    dflags = hsc_dflags hsc_env  simplExprGently :: SimplEnv -> CoreExpr -> SimplM CoreExpr -- Simplifies an expression@@ -592,7 +599,7 @@ --      (b) the LHS and RHS of a RULE --      (c) Template Haskell splices ----- The name 'Gently' suggests that the SimplMode is SimplGently,+-- 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 @@ -694,7 +701,7 @@                      (pprCoreBindings tagged_binds);                  -- Get any new rules, and extend the rule base-                -- See Note [Overall plumbing for rules] in Rules.hs+                -- 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@@ -1020,6 +1027,7 @@   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
compiler/simplCore/SimplEnv.hs view
@@ -49,15 +49,15 @@  import SimplMonad import CoreMonad                ( SimplMode(..) )-import CoreSyn-import CoreUtils+import GHC.Core+import GHC.Core.Utils import Var import VarEnv import VarSet import OrdList import Id-import MkCore                   ( mkWildValBinder )-import DynFlags                 ( DynFlags )+import GHC.Core.Make            ( mkWildValBinder )+import GHC.Driver.Session       ( DynFlags ) import TysWiredIn import qualified Type import Type hiding              ( substTy, substTyVar, substTyVarBndr )@@ -69,7 +69,7 @@ import Util import UniqFM                   ( pprUniqFM ) -import Data.List+import Data.List (mapAccumL)  {- ************************************************************************@@ -149,7 +149,7 @@              | otherwise = ppr v  type SimplIdSubst = IdEnv SimplSR -- IdId |--> OutExpr-        -- See Note [Extending the Subst] in CoreSubst+        -- See Note [Extending the Subst] in GHC.Core.Subst  -- | A substitution result. data SimplSR@@ -290,7 +290,7 @@ Id in the in-scope set  There can be *occurrences* of wild-id.  For example,-MkCore.mkCoreApp transforms+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@@ -498,7 +498,7 @@       | not (isStrictId bndr)    = FltLifted       | exprIsTickedString rhs   = FltLifted           -- String literals can be floated freely.-          -- See Note [CoreSyn top-level string literals] in CoreSyn.+          -- 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@@ -805,7 +805,7 @@ -- Augment the substitution  if the unique changed -- Extend the in-scope set with the new Id ----- Similar to CoreSubst.substIdBndr, except that+-- Similar to GHC.Core.Subst.substIdBndr, except that --      the type of id_subst differs --      all fragile info is zapped substNonCoVarIdBndr new_res_ty
compiler/simplCore/SimplMonad.hs view
@@ -28,9 +28,9 @@ import IdInfo           ( IdDetails(..), vanillaIdInfo, setArityInfo ) import Type             ( Type, mkLamTypes ) import FamInstEnv       ( FamInstEnv )-import CoreSyn          ( RuleEnv(..) )+import GHC.Core         ( RuleEnv(..) ) import UniqSupply-import DynFlags+import GHC.Driver.Session import CoreMonad import Outputable import FastString@@ -189,7 +189,7 @@        ; 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+             -- 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
compiler/simplCore/SimplUtils.hs view
@@ -42,15 +42,15 @@  import SimplEnv import CoreMonad        ( SimplMode(..), Tick(..) )-import DynFlags-import CoreSyn-import qualified CoreSubst-import PprCore+import GHC.Driver.Session+import GHC.Core+import qualified GHC.Core.Subst+import GHC.Core.Ppr import TyCoPpr          ( pprParendType )-import CoreFVs-import CoreUtils-import CoreArity-import CoreUnfold+import GHC.Core.FVs+import GHC.Core.Utils+import GHC.Core.Arity+import GHC.Core.Unfold import Name import Id import IdInfo@@ -353,7 +353,7 @@ mkBoringStop :: OutType -> SimplCont mkBoringStop ty = Stop ty BoringCtxt -mkRhsStop :: OutType -> SimplCont       -- See Note [RHS of lets] in CoreUnfold+mkRhsStop :: OutType -> SimplCont       -- See Note [RHS of lets] in GHC.Core.Unfold mkRhsStop ty = Stop ty RhsCtxt  mkLazyArgStop :: OutType -> CallCtxt -> SimplCont@@ -432,7 +432,7 @@   | lone cont = (True, [], cont)   | otherwise = go [] cont   where-    lone (ApplyToTy  {}) = False  -- See Note [Lone variables] in CoreUnfold+    lone (ApplyToTy  {}) = False  -- See Note [Lone variables] in GHC.Core.Unfold     lone (ApplyToVal {}) = False     lone (CastIt {})     = False     lone _               = True@@ -499,7 +499,7 @@                         -- top-level bindings for (say) strings into                         -- calls to error.  But now we are more careful about                         -- inlining lone variables, so its ok (see SimplUtils.analyseCont)-                   if isBotRes result_info then+                   if isBotDiv result_info then                         map isStrictDmd demands         -- Finite => result is bottom                    else                         map isStrictDmd demands ++ vanilla_stricts@@ -632,7 +632,7 @@         -- 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+        -- in GHC.Core.Unfold      interesting (StrictArg { sc_cci = cci }) = cci     interesting (StrictBind {})              = BoringCtxt@@ -1135,7 +1135,7 @@     -> 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+-- 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@@ -1259,7 +1259,7 @@     -> OutExpr     -> Bool -- Precondition: rhs satisfies the let/app invariant--- See Note [CoreSyn let/app invariant] in CoreSyn+-- 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@@ -1517,7 +1517,7 @@          -- 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+         -- Note [Invariants on join points] invariant 2b, in GHC.Core    | otherwise   = do { (new_arity, is_bot, new_rhs) <- try_expand@@ -1553,7 +1553,7 @@ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 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+(in GHC.Core.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 => ...@@ -1575,7 +1575,7 @@  Note [Do not eta-expand join points] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Similarly to CPR (see Note [Don't CPR join points] in WorkWrap), a join point+Similarly to CPR (see Note [Don't w/w join points for CPR] 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: @@ -1747,21 +1747,21 @@   = 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) }+        ; return (float_binds, GHC.Core.Subst.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)+    empty_subst = GHC.Core.Subst.mkEmptySubst (sfInScope floats) -    abstract :: CoreSubst.Subst -> OutBind -> SimplM (CoreSubst.Subst, OutBind)+    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' = CoreSubst.extendIdSubst subst id poly_app+                 subst' = GHC.Core.Subst.extendIdSubst subst id poly_app            ; return (subst', NonRec poly_id2 poly_rhs) }       where-        rhs' = CoreSubst.substExpr (text "abstract_floats2") subst rhs+        rhs' = GHC.Core.Subst.substExpr (text "abstract_floats2") subst rhs          -- tvs_here: see Note [Which type variables to abstract over]         tvs_here = scopedSort $@@ -1771,10 +1771,10 @@      abstract subst (Rec prs)        = do { (poly_ids, poly_apps) <- mapAndUnzipM (mk_poly1 tvs_here) ids-            ; let subst' = CoreSubst.extendSubstList subst (ids `zip` poly_apps)+            ; 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' = CoreSubst.substExpr (text "abstract_floats")+                               , let rhs' = GHC.Core.Subst.substExpr (text "abstract_floats")                                                                 subst' rhs ]             ; return (subst', Rec poly_pairs) }        where@@ -2207,7 +2207,7 @@      re_sort :: [CoreAlt] -> [CoreAlt]     -- Sort the alternatives to re-establish-    -- CoreSyn Note [Case expression invariants]+    -- GHC.Core Note [Case expression invariants]     re_sort alts = sortBy cmpAlt alts      add_default :: [CoreAlt] -> [CoreAlt]
compiler/simplCore/Simplify.hs view
@@ -13,7 +13,7 @@  import GhcPrelude -import DynFlags+import GHC.Driver.Session import SimplMonad import Type hiding      ( substTy, substTyVar, extendTvSubst, extendCvSubst ) import SimplEnv@@ -23,8 +23,8 @@ 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 GHC.Core.Make           ( FloatBind, mkImpossibleExpr, castBottomExpr )+import qualified GHC.Core.Make import IdInfo import Name             ( mkSystemVarName, isExternalName, getOccFS ) import Coercion hiding  ( substCo, substCoVar )@@ -34,15 +34,16 @@                         , dataConRepArgTys, isUnboxedTupleCon                         , StrictnessMark (..) ) import CoreMonad        ( Tick(..), SimplMode(..) )-import CoreSyn-import Demand           ( StrictSig(..), 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, botRes )+import GHC.Core+import Demand           ( StrictSig(..), dmdTypeDepth, isStrictDmd+                        , mkClosedStrictSig, topDmd, botDiv )+import Cpr              ( mkCprSig, botCpr )+import GHC.Core.Ppr     ( pprCoreExpr )+import GHC.Core.Unfold+import GHC.Core.Utils+import GHC.Core.SimpleOpt ( pushCoTyArg, pushCoValArg+                          , joinPointBinding_maybe, joinPointBindings_maybe )+import GHC.Core.Rules   ( mkRuleInfo, lookupRule, getRules ) import BasicTypes       ( TopLevelFlag(..), isNotTopLevel, isTopLevel,                           RecFlag(..), Arity ) import MonadUtils       ( mapAccumLM, liftIO )@@ -385,7 +386,7 @@                 -> 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+--               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 )@@ -447,6 +448,7 @@         ; return (floats, Cast rhs' co) }   where     sanitised_info = vanillaIdInfo `setStrictnessInfo` strictnessInfo info+                                   `setCprInfo`        cprInfo info                                    `setDemandInfo`     demandInfo info  prepareRhs mode top_lvl occ _ rhs0@@ -632,7 +634,7 @@    foo1 = "blob"#    foo = Ptr foo1 -See Note [CoreSyn top-level string literals] in CoreSyn.+See Note [Core top-level string literals] in GHC.Core.  ************************************************************************ *                                                                      *@@ -731,8 +733,10 @@           = info2      -- Bottoming bindings: see Note [Bottoming bindings]-    info4 | is_bot    = info3 `setStrictnessInfo`-                        mkClosedStrictSig (replicate new_arity topDmd) botRes+    info4 | is_bot    = info3+                          `setStrictnessInfo`+                            mkClosedStrictSig (replicate new_arity topDmd) botDiv+                          `setCprInfo` mkCprSig new_arity botCpr           | otherwise = info3       -- Zap call arity info. We have used it by now (via@@ -778,7 +782,7 @@ possible.  We use tryEtaExpandRhs on every binding, and it turns ou that the-arity computation it performs (via CoreArity.findRhsArity) already+arity computation it performs (via GHC.Core.Arity.findRhsArity) already does a simple bottoming-expression analysis.  So all we need to do is propagate that info to the binder's IdInfo. @@ -1169,7 +1173,7 @@   splitCont other = (mkBoringStop (contHoleType other), other)    getDoneId (DoneId id)  = id-  getDoneId (DoneEx e _) = getIdFromTrivialExpr e -- Note [substTickish] in CoreSubst+  getDoneId (DoneEx e _) = getIdFromTrivialExpr e -- Note [substTickish] in GHC.Core.Subst   getDoneId other = pprPanic "getDoneId" (ppr other)  -- Note [case-of-scc-of-case]@@ -1322,7 +1326,7 @@           | 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 CoreSyn+                                        -- See Note [Levity polymorphism invariants] in GHC.Core                                         -- test: typecheck/should_run/EtaExpandLevPoly           = {-#SCC "addCoerce-pushCoValArg" #-}             do { tail' <- addCoerceM m_co2 tail@@ -1453,7 +1457,7 @@ -- which may abort the whole process -- -- Precondition: rhs satisfies the let/app invariant---               Note [CoreSyn let/app invariant] in CoreSyn+--               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@@ -2310,7 +2314,7 @@   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.+  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@@ -2342,7 +2346,7 @@ 'pseq'.  See #8900 for an example where the loss of this transformation bit us in practice. -See also Note [Empty case alternatives] in CoreSyn.+See also Note [Empty case alternatives] in GHC.Core.  Historical notes @@ -2373,7 +2377,7 @@     case_bndr_evald_next _               = False    This patch was part of fixing #7542. See also-  Note [Eta reduction of an eval'd function] in CoreUtils.)+  Note [Eta reduction of an eval'd function] in GHC.Core.Utils.)   Further notes about case elimination@@ -2487,7 +2491,7 @@              _ -> return                -- See Note [FloatBinds from constructor wrappers]                    ( emptyFloats env,-                     MkCore.wrapFloats wfloats $+                     GHC.Core.Make.wrapFloats wfloats $                      wrapFloats (floats1 `addFloats` floats2) expr' )}  @@ -2547,8 +2551,8 @@ -- 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]+  | isTyCoVar case_bndr    -- Respect GHC.Core+  = isTyCoArg scrut        -- Note [Core type and coercion invariant]    | isUnliftedType (idType case_bndr)   = exprOkForSpeculation scrut@@ -2932,7 +2936,7 @@             _ ->               return ( emptyFloats env                -- See Note [FloatBinds from constructor wrappers]-                     , MkCore.wrapFloats dc_floats $+                     , GHC.Core.Make.wrapFloats dc_floats $                        wrapFloats (floats1 `addFloats` floats2 `addFloats` floats3) expr') }   where     zap_occ = zapBndrOccInfo (isDeadBinder bndr)    -- bndr is an InId@@ -3552,7 +3556,7 @@                         -- 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+                            -- See Note [Top-level flag on inline rules] in GHC.Core.Unfold                    _other              -- Happens for INLINABLE things                      -> mkLetUnfolding dflags top_lvl src id expr' }
compiler/specialise/SpecConstr.hs view
@@ -23,31 +23,32 @@  import GhcPrelude -import CoreSyn-import CoreSubst-import CoreUtils-import CoreUnfold       ( couldBeSmallEnoughToInline )-import CoreFVs          ( exprsFreeVarsList )+import GHC.Core+import GHC.Core.Subst+import GHC.Core.Utils+import GHC.Core.Unfold  ( couldBeSmallEnoughToInline )+import GHC.Core.FVs     ( exprsFreeVarsList ) import CoreMonad import Literal          ( litIsLifted )-import HscTypes         ( ModGuts(..) )+import GHC.Driver.Types ( ModGuts(..) ) import WwLib            ( isWorkerSmallEnough, mkWorkerArgs ) import DataCon import Coercion         hiding( substCo )-import Rules+import GHC.Core.Rules import Type             hiding ( substTy ) import TyCon            ( tyConName ) import Id-import PprCore          ( pprParendExpr )-import MkCore           ( mkImpossibleExpr )+import GHC.Core.Ppr     ( pprParendExpr )+import GHC.Core.Make    ( mkImpossibleExpr ) import VarEnv import VarSet import Name import BasicTypes-import DynFlags         ( DynFlags(..), GeneralFlag( Opt_SpecConstrKeen )-                        , gopt, hasPprDebug )+import GHC.Driver.Session ( DynFlags(..), GeneralFlag( Opt_SpecConstrKeen )+                          , gopt, hasPprDebug ) import Maybes           ( orElse, catMaybes, isJust, isNothing ) import Demand+import Cpr import GHC.Serialized   ( deserializeWithData ) import Util import Pair@@ -1726,6 +1727,7 @@                                      (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@@ -1759,7 +1761,7 @@                    -> StrictSig              -- Strictness of specialised thing -- See Note [Transfer strictness] calcSpecStrictness fn qvars pats-  = mkClosedStrictSig spec_dmds topRes+  = mkClosedStrictSig spec_dmds topDiv   where     spec_dmds = [ lookupVarEnv dmd_env qv `orElse` topDmd | qv <- qvars, isId qv ]     StrictSig (DmdType _ dmds _) = idStrictness fn@@ -2152,7 +2154,7 @@         -- 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+        --- See Note [Notes 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@@ -2239,7 +2241,7 @@ --      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+--      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
compiler/specialise/Specialise.hs view
@@ -22,26 +22,26 @@ import Module( Module, HasModule(..) ) import Coercion( Coercion ) import CoreMonad-import qualified CoreSubst-import CoreUnfold+import qualified GHC.Core.Subst+import GHC.Core.Unfold import Var              ( isLocalVar ) import VarSet import VarEnv-import CoreSyn-import Rules-import CoreOpt          ( collectBindersPushingCo )-import CoreUtils        ( exprIsTrivial, mkCast, exprType )-import CoreFVs-import CoreArity        ( etaExpandToJoinPointRule )+import GHC.Core+import GHC.Core.Rules+import GHC.Core.SimpleOpt ( collectBindersPushingCo )+import GHC.Core.Utils     ( exprIsTrivial, mkCast, exprType )+import GHC.Core.FVs+import GHC.Core.Arity     ( etaExpandToJoinPointRule ) import UniqSupply import Name import MkId             ( voidArgId, voidPrimId ) import Maybes           ( mapMaybe, isJust ) import MonadUtils       ( foldlM ) import BasicTypes-import HscTypes+import GHC.Driver.Types import Bag-import DynFlags+import GHC.Driver.Session import Util import Outputable import FastString@@ -607,7 +607,7 @@         -- 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 = CoreSubst.mkEmptySubst $ mkInScopeSet $ mkVarSet $+    top_env = SE { se_subst = GHC.Core.Subst.mkEmptySubst $ mkInScopeSet $ mkVarSet $                               bindersOfBinds binds                  , se_interesting = emptyVarSet } @@ -1036,7 +1036,7 @@ -}  data SpecEnv-  = SE { se_subst :: CoreSubst.Subst+  = SE { se_subst :: GHC.Core.Subst.Subst              -- We carry a substitution down:              -- a) we must clone any binding that might float outwards,              --    to avoid name clashes@@ -1051,7 +1051,7 @@      }  specVar :: SpecEnv -> Id -> CoreExpr-specVar env v = CoreSubst.lookupIdSubst (text "specVar") (se_subst env) v+specVar env v = GHC.Core.Subst.lookupIdSubst (text "specVar") (se_subst env) v  specExpr :: SpecEnv -> CoreExpr -> SpecM (CoreExpr, UsageDetails) @@ -1144,7 +1144,7 @@              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 = CoreSubst.extendIdSubstList (se_subst env_rhs) subst_prs+             env_rhs' = env_rhs { se_subst = GHC.Core.Subst.extendIdSubstList (se_subst env_rhs) subst_prs                                 , se_interesting = se_interesting env_rhs `extendVarSetList`                                                    (case_bndr_flt : sc_args_flt) } @@ -1402,7 +1402,7 @@                                  -- See Note [Account for casts in binding]     rhs_tyvars = filter isTyVar rhs_bndrs -    in_scope = CoreSubst.substInScope (se_subst env)+    in_scope = GHC.Core.Subst.substInScope (se_subst env)      already_covered :: DynFlags -> [CoreRule] -> [CoreExpr] -> Bool     already_covered dflags new_rules args      -- Note [Specialisations already covered]@@ -1438,7 +1438,7 @@                  (lam_extra_args, app_args)     -- See Note [Specialisations Must Be Lifted]                    | isUnliftedType body_ty     -- C.f. WwLib.mkWorkerArgs                    , not (isJoinId fn)-                   = ([voidArgId], unspec_bndrs ++ [voidPrimId])+                   = ([voidArgId], voidPrimId : unspec_bndrs)                    | otherwise = ([], unspec_bndrs)                  join_arity_change = length app_args - length rule_args                  spec_join_arity | Just orig_join_arity <- isJoinId_maybe fn@@ -1691,9 +1691,9 @@   = (env', dx_binds, spec_dict_args)   where     (dx_binds, spec_dict_args) = go call_ds inst_dict_ids-    env' = env { se_subst = subst `CoreSubst.extendSubstList`+    env' = env { se_subst = subst `GHC.Core.Subst.extendSubstList`                                      (orig_dict_ids `zip` spec_dict_args)-                                  `CoreSubst.extendInScopeList` dx_ids+                                  `GHC.Core.Subst.extendInScopeList` dx_ids                , se_interesting = interesting `unionVarSet` interesting_dicts }      dx_ids = [dx_id | (NonRec dx_id _, _) <- dx_binds]@@ -2595,20 +2595,20 @@  extendTvSubstList :: SpecEnv -> [(TyVar,Type)] -> SpecEnv extendTvSubstList env tv_binds-  = env { se_subst = CoreSubst.extendTvSubstList (se_subst env) tv_binds }+  = env { se_subst = GHC.Core.Subst.extendTvSubstList (se_subst env) tv_binds }  substTy :: SpecEnv -> Type -> Type-substTy env ty = CoreSubst.substTy (se_subst env) ty+substTy env ty = GHC.Core.Subst.substTy (se_subst env) ty  substCo :: SpecEnv -> Coercion -> Coercion-substCo env co = CoreSubst.substCo (se_subst env) co+substCo env co = GHC.Core.Subst.substCo (se_subst env) co  substBndr :: SpecEnv -> CoreBndr -> (SpecEnv, CoreBndr)-substBndr env bs = case CoreSubst.substBndr (se_subst env) bs of+substBndr env bs = case GHC.Core.Subst.substBndr (se_subst env) bs of                       (subst', bs') -> (env { se_subst = subst' }, bs')  substBndrs :: SpecEnv -> [CoreBndr] -> (SpecEnv, [CoreBndr])-substBndrs env bs = case CoreSubst.substBndrs (se_subst env) bs of+substBndrs env bs = case GHC.Core.Subst.substBndrs (se_subst env) bs of                       (subst', bs') -> (env { se_subst = subst' }, bs')  cloneBindSM :: SpecEnv -> CoreBind -> SpecM (SpecEnv, SpecEnv, CoreBind)@@ -2616,7 +2616,7 @@ -- 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') = CoreSubst.cloneIdBndr subst us bndr+       ; let (subst', bndr') = GHC.Core.Subst.cloneIdBndr subst us bndr              interesting' | interestingDict env rhs                           = interesting `extendVarSet` bndr'                           | otherwise = interesting@@ -2625,7 +2625,7 @@  cloneBindSM env@(SE { se_subst = subst, se_interesting = interesting }) (Rec pairs)   = do { us <- getUniqueSupplyM-       ; let (subst', bndrs') = CoreSubst.cloneRecIdBndrs subst us (map fst pairs)+       ; let (subst', bndrs') = GHC.Core.Subst.cloneRecIdBndrs subst us (map fst pairs)              env' = env { se_subst = subst'                         , se_interesting = interesting `extendVarSetList`                                            [ v | (v,r) <- pairs, interestingDict env r ] }
+ compiler/stranal/CprAnal.hs view
@@ -0,0 +1,669 @@+{-# 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 CprAnal ( cprAnalProgram ) where++#include "HsVersions.h"++import GhcPrelude++import WwLib            ( deepSplitProductType_maybe )+import GHC.Driver.Session+import Demand+import Cpr+import GHC.Core+import GHC.Core.Seq+import Outputable+import VarEnv+import BasicTypes+import Data.List+import DataCon+import Id+import IdInfo+import GHC.Core.Utils   ( exprIsHNF, dumpIdInfoOfProgram )+import TyCon+import Type+import FamInstEnv+import Util+import ErrUtils         ( dumpIfSet_dyn, DumpFormat (..) )+import Maybes           ( isJust, isNothing )++{- 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 strict binders].+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 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)+  = (extendAnalEnv env id' (idCprInfo id'), NonRec id' rhs')+  where+    (id', rhs') = 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 (Var var)   = (cprTransform env var, Var var)++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 (App fun (Type ty))+  = (fun_ty, App fun' (Type ty))+  where+    (fun_ty, fun') = cprAnal env fun++cprAnal' env (App fun arg)+  = (res_ty, App fun' arg')+  where+    (fun_ty, fun') = cprAnal env fun+    -- In contrast to DmdAnal, there is no useful (non-nested) CPR info to be+    -- had by looking into the CprType of arg.+    (_, arg')      = cprAnal env arg+    res_ty         = applyCprTy fun_ty++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'             = extendSigsWithLam env 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')      = cprAnalBind NotTopLevel env id rhs+    env'             = extendAnalEnv env id' (idCprInfo id')+    (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+--++cprTransform :: AnalEnv         -- ^ The analysis environment+             -> Id              -- ^ The function+             -> CprType         -- ^ The demand type of the function+cprTransform env id+  = -- pprTrace "cprTransform" (vcat [ppr id, ppr sig])+    sig+  where+    sig+      | isGlobalId id                   -- imported function or data con worker+      = getCprSig (idCprInfo id)+      | Just sig <- lookupSigEnv env id -- local let-bound+      = getCprSig sig+      | otherwise+      = topCprType++--+-- * Bindings+--++-- Recursive bindings+cprFix :: TopLevelFlag+       -> AnalEnv                            -- Does not include bindings for this binding+       -> [(Id,CoreExpr)]+       -> (AnalEnv, [(Id,CoreExpr)]) -- Binders annotated with stricness info++cprFix top_lvl env orig_pairs+  = loop 1 initial_pairs+  where+    bot_sig = mkCprSig 0 botCpr+    -- See Note [Initialising strictness] in DmdAnal.hs+    initial_pairs | ae_virgin env = [(setIdCprInfo id bot_sig, rhs) | (id, rhs) <- orig_pairs ]+                  | otherwise     = orig_pairs++    -- The fixed-point varies the idCprInfo field of the binders, and terminates if that+    -- annotation does not change any more.+    loop :: Int -> [(Id,CoreExpr)] -> (AnalEnv, [(Id,CoreExpr)])+    loop n pairs+      | found_fixpoint = (final_anal_env, pairs')+      | otherwise      = loop (n+1) pairs'+      where+        found_fixpoint    = map (idCprInfo . fst) pairs' == map (idCprInfo . fst) pairs+        first_round       = n == 1+        pairs'            = step first_round pairs+        final_anal_env    = extendAnalEnvs env (map fst pairs')++    step :: Bool -> [(Id, CoreExpr)] -> [(Id, CoreExpr)]+    step first_round pairs = pairs'+      where+        -- In all but the first iteration, delete the virgin flag+        start_env | first_round = env+                  | otherwise   = nonVirgin env++        start = extendAnalEnvs start_env (map fst pairs)++        (_, pairs') = mapAccumL my_downRhs start pairs++        my_downRhs env (id,rhs)+          = (env', (id', rhs'))+          where+            (id', rhs') = cprAnalBind top_lvl env id rhs+            env'        = extendAnalEnv env id (idCprInfo id')++-- | 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)+cprAnalBind top_lvl env id rhs+  = (id', rhs')+  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++    -- 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++{- 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 "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 strictness IDs attached to the id+extendAnalEnvs :: AnalEnv -> [Id] -> AnalEnv+extendAnalEnvs env ids+  = env { ae_sigs = sigs' }+  where+    sigs' = extendVarEnvList (ae_sigs env) [ (id, idCprInfo id) | id <- ids ]++extendAnalEnv :: AnalEnv -> Id -> CprSig -> AnalEnv+extendAnalEnv 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 }++extendSigsWithLam :: AnalEnv -> Id -> AnalEnv+-- Extend the AnalEnv when we meet a lambda binder+extendSigsWithLam env id+  | isId id+  , isStrictDmd (idDemandInfo id) -- See Note [CPR for strict binders]+  , Just (dc,_,_,_) <- deepSplitProductType_maybe (ae_fam_envs env) $ idType id+  = extendAnalEnv env id (CprSig (conCprType (dataConTag dc)))+  | otherwise+  = env++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' = extendAnalEnv 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 strict binders] don't apply to sums (yet);+    -- we lack WW for strict binders of sum type.+    do_con_arg env (id, str)+       | let is_strict = isStrictDmd (idDemandInfo id) || isMarkedStrict str+       , is_var_scrut && is_strict+       , let fam_envs = ae_fam_envs env+       , Just (dc,_,_,_) <- deepSplitProductType_maybe fam_envs $ idType id+       = extendAnalEnv env id (CprSig (conCprType (dataConTag 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++{- 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 strict binders]+   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 strict binders]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If a lambda-bound variable is marked demanded with a strict demand, then give it+a CPR signature, anticipating the results of worker/wrapper. 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 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.++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)+++    ------- 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+-}
compiler/stranal/DmdAnal.hs view
@@ -15,18 +15,19 @@  import GhcPrelude -import DynFlags-import WwLib            ( findTypeShape, deepSplitProductType_maybe )+import GHC.Driver.Session+import WwLib            ( findTypeShape ) import Demand   -- All of it-import CoreSyn-import CoreSeq          ( seqBinds )+import GHC.Core+import GHC.Core.Seq     ( seqBinds ) import Outputable import VarEnv import BasicTypes-import Data.List+import Data.List        ( mapAccumL ) import DataCon import Id-import CoreUtils        ( exprIsHNF, exprType, exprIsTrivial, exprOkForSpeculation )+import IdInfo+import GHC.Core.Utils import TyCon import Type import Coercion         ( Coercion, coVarsOfCo )@@ -36,8 +37,6 @@ import TysWiredIn import TysPrim          ( realWorldStatePrimTy ) import ErrUtils         ( dumpIfSet_dyn, DumpFormat (..) )-import Name             ( getName, stableNameCmp )-import Data.Function    ( on ) import UniqSet  {-@@ -49,32 +48,22 @@ -}  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" FormatText-            (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+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 id2 (idStrictness id2), NonRec id2 rhs2)+  = (extendAnalEnv TopLevel env id' (idStrictness id'), NonRec id' rhs')   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]+    ( _, id', rhs') = dmdAnalRhsLetDown Nothing env cleanEvalDmd id rhs  dmdAnalTopBind env (Rec pairs)   = (env', Rec pairs')@@ -217,8 +206,7 @@   = 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+        (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')@@ -229,8 +217,7 @@   , 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+        env_alt                  = env { ae_rec_tc = rec_tc' }         (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@@ -298,7 +285,7 @@ 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+    (lazy_fv, id1, rhs') = dmdAnalRhsLetDown 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@@ -474,8 +461,8 @@   = 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])+  , let res = dmdTransformSig (idStrictness var) dmd+  = -- pprTrace "dmdTransform" (vcat [ppr var, ppr (idStrictness var), ppr dmd, ppr res])     res    | Just (sig, top_lvl) <- lookupSigEnv env var  -- Local letrec bound thing@@ -552,7 +539,7 @@         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_fv1, id', rhs') = dmdAnalRhsLetDown (Just bndrs) env let_dmd id rhs             lazy_fv'              = plusVarEnv_C bothDmd lazy_fv lazy_fv1             env'                  = extendAnalEnv top_lvl env id (idStrictness id') @@ -590,20 +577,20 @@ -- 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)+dmdAnalRhsLetDown+  :: 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+dmdAnalRhsLetDown 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+      -- 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@@ -611,9 +598,11 @@       -- 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')+    (DmdType rhs_fv rhs_dmds rhs_div, rhs')                    = dmdAnal env rhs_dmd rhs-    sig            = mkStrictSigForArity rhs_arity (mkDmdType sig_fv rhs_dmds rhs_res')+    -- TODO: Won't the following line unnecessarily trim down arity for join+    --       points returning a lambda in a C(S) context?+    sig            = mkStrictSigForArity rhs_arity (mkDmdType sig_fv rhs_dmds rhs_div)     id'            = set_idStrictness env id sig         -- See Note [NOINLINE and strictness] @@ -625,18 +614,7 @@      -- 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@@ -790,7 +768,7 @@  Note [idArity varies independently of dmdTypeDepth] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We used to check in CoreLint that dmdTypeDepth <= idArity for a let-bound+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 @@ -874,9 +852,9 @@ 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+Fortunately, GHC.Core.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-CoreArity)! A small example is the test case NewtypeArity.+GHC.Core.Arity)! A small example is the test case NewtypeArity.   Note [Product demands for function body]@@ -911,7 +889,7 @@ -}  unitDmdType :: DmdEnv -> DmdType-unitDmdType dmd_env = DmdType dmd_env [] topRes+unitDmdType dmd_env = DmdType dmd_env [] topDiv  coercionDmdEnv :: Coercion -> DmdEnv coercionDmdEnv co = mapVarEnv (const topDmd) (getUniqSet $ coVarsOfCo co)@@ -1003,119 +981,6 @@   = 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@@ -1289,43 +1154,6 @@ 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@@ -1367,158 +1195,8 @@ 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]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+{- 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
compiler/stranal/WorkWrap.hs view
@@ -9,19 +9,20 @@  import GhcPrelude -import CoreArity        ( manifestArity )-import CoreSyn-import CoreUnfold       ( certainlyWillInline, mkWwInlineRule, mkWorkerUnfolding )-import CoreUtils        ( exprType, exprIsHNF )-import CoreFVs          ( exprFreeVars )+import GHC.Core.Arity  ( manifestArity )+import GHC.Core+import GHC.Core.Unfold ( certainlyWillInline, mkWwInlineRule, mkWorkerUnfolding )+import GHC.Core.Utils  ( exprType, exprIsHNF )+import GHC.Core.FVs    ( exprFreeVars ) import Var import Id import IdInfo import Type import UniqSupply import BasicTypes-import DynFlags+import GHC.Driver.Session import Demand+import Cpr import WwLib import Util import Outputable@@ -200,7 +201,7 @@   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.+in work_fn! See GHC.Core.Unfold.mkWorkerUnfolding.  Note [Worker-wrapper for NOINLINE functions] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -336,13 +337,13 @@ 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.+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@@ -362,11 +363,14 @@           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:+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 ... @@ -459,7 +463,7 @@         -- 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+  = 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@@ -469,8 +473,15 @@    where     fn_info      = idInfo fn_id-    (wrap_dmds, res_info) = splitStrictSig (strictnessInfo fn_info)+    (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 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 in WorkWrap]@@ -523,12 +534,12 @@ 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+means GHC.Core.Arity didn't eta expand that binding. When this happens, it does so+for a reason (see Note [exprArity invariant] in GHC.Core.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 CoreArity's decision. Other than playing fast and loose with+idArity, overriding GHC.Core.Arity's decision. Other than playing fast and loose with divergence, it's also broken for newtypes:    f = (\xy.blah) |> co@@ -553,12 +564,12 @@   ----------------------splitFun :: DynFlags -> FamInstEnvs -> Id -> IdInfo -> [Demand] -> DmdResult -> CoreExpr+splitFun :: DynFlags -> FamInstEnvs -> Id -> IdInfo -> [Demand] -> Divergence -> CprResult -> 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+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_res_info+    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@@ -579,7 +590,7 @@             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])+              -- (see Note [Don't w/w join points for CPR])              work_id  = mkWorkerId work_uniq fn_id (exprType work_rhs)                         `setIdOccInfo` occInfo fn_info@@ -593,10 +604,12 @@                         `setIdUnfolding` mkWorkerUnfolding dflags work_fn fn_unfolding                                 -- See Note [Worker-wrapper for INLINABLE functions] -                        `setIdStrictness` mkClosedStrictSig work_demands work_res_info+                        `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@@ -649,13 +662,16 @@                     -- 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+    -- 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   {-
compiler/stranal/WwLib.hs view
@@ -15,13 +15,14 @@  import GhcPrelude -import CoreSyn-import CoreUtils        ( exprType, mkCast, mkDefaultCase, mkSingleAltCase )+import GHC.Core+import GHC.Core.Utils   ( exprType, mkCast, mkDefaultCase, mkSingleAltCase ) import Id import IdInfo           ( JoinArity ) import DataCon import Demand-import MkCore           ( mkAbsentErrorApp, mkCoreUbxTup+import Cpr+import GHC.Core.Make    ( mkAbsentErrorApp, mkCoreUbxTup                         , mkCoreApp, mkCoreLet ) import MkId             ( voidArgId, voidPrimId ) import TysWiredIn       ( tupleDataCon )@@ -41,7 +42,7 @@ import Maybes import Util import Outputable-import DynFlags+import GHC.Driver.Session import FastString import ListSetOps @@ -126,7 +127,7 @@                              -- See Note [Freshen WW arguments]            -> Id             -- The original function            -> [Demand]       -- Strictness of original function-           -> DmdResult      -- Info about function result+           -> CprResult      -- Info about function result            -> UniqSM (Maybe WwResult)  -- wrap_fn_args E       = \x y -> E@@ -140,7 +141,7 @@ --                        let x = (a,b) in --                        E -mkWwBodies dflags fam_envs rhs_fvs fun_id demands res_info+mkWwBodies dflags fam_envs rhs_fvs fun_id demands cpr_info   = do  { let empty_subst = mkEmptyTCvSubst (mkInScopeSet rhs_fvs)                 -- See Note [Freshen WW arguments] @@ -151,7 +152,7 @@          -- 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+              <- 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]@@ -579,7 +580,7 @@   = return (False, [arg],  nop_fn, nop_fn)    | isAbsDmd dmd-  , Just work_fn <- mk_absent_let dflags arg+  , 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)@@ -993,18 +994,18 @@ mkWWcpr :: Bool         -> FamInstEnvs         -> Type                              -- function body type-        -> DmdResult                         -- CPR analysis results+        -> 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 res+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 returnsCPR_maybe res of+  = case asConCpr cpr 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@@ -1084,6 +1085,9 @@ 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] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -1149,8 +1153,8 @@ -- 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+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)@@ -1161,20 +1165,22 @@   = 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 tc <- tyConAppTyCon_maybe nty   , Just lit <- absentLiteralOf tc-  = Just (Let (NonRec arg (Lit lit)))-  | arg_ty `eqType` voidPrimTy-  = Just (Let (NonRec arg (Var voidPrimId)))+  = 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+    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+    (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))
compiler/typecheck/ClsInst.hs view
@@ -32,14 +32,14 @@  import Id import Type-import MkCore ( mkStringExprFS, mkNaturalExpr )+import GHC.Core.Make ( mkStringExprFS, mkNaturalExpr )  import Name   ( Name, pprDefinedAt ) import VarEnv ( VarEnv ) import DataCon import TyCon import Class-import DynFlags+import GHC.Driver.Session import Outputable import Util( splitAtList, fstOf3 ) import Data.Maybe
compiler/typecheck/FamInst.hs view
@@ -15,11 +15,11 @@  import GhcPrelude -import HscTypes+import GHC.Driver.Types import FamInstEnv import InstEnv( roughMatchTcs ) import Coercion-import CoreLint+import GHC.Core.Lint import TcEvidence import GHC.Iface.Load import TcRnMonad@@ -27,7 +27,7 @@ import TyCon import TcType import CoAxiom-import DynFlags+import GHC.Driver.Session import Module import Outputable import Util@@ -44,7 +44,9 @@ import FV import 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 @@ -239,7 +241,7 @@  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.)+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]@@ -1032,7 +1034,7 @@   = return ()  -- No conflicts reportConflictInstErr fam_inst (match1 : _)   | FamInstMatch { fim_instance = conf_inst } <- match1-  , let sorted  = sortWith getSpan [fam_inst, conf_inst]+  , let sorted  = sortBy (SrcLoc.leftmost_smallest `on` getSpan) [fam_inst, conf_inst]         fi1     = head sorted         span    = coAxBranchSpan (coAxiomSingleBranch (famInstAxiom fi1))   = setSrcSpan span $ addErr $@@ -1041,8 +1043,8 @@                | fi <- sorted                , let ax = famInstAxiom fi ])  where-   getSpan = getSrcLoc . famInstAxiom-   -- The sortWith just arranges that instances are displayed in order+   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
compiler/typecheck/Inst.hs view
@@ -52,17 +52,17 @@ import TcEvidence import InstEnv import TysWiredIn  ( heqDataCon, eqDataCon )-import CoreSyn     ( isOrphan )+import GHC.Core    ( isOrphan ) import FunDeps import TcMType import Type import TyCoRep import TyCoPpr     ( debugPprType ) import TcType-import HscTypes+import GHC.Driver.Types import Class( Class ) import MkId( mkDictFunId )-import CoreSyn( Expr(..) )  -- For the Coercion constructor+import GHC.Core( Expr(..) )  -- For the Coercion constructor import Id import Name import Var      ( EvVar, tyVarName, VarBndr(..) )@@ -70,13 +70,15 @@ import VarEnv import PrelNames import SrcLoc-import DynFlags+import GHC.Driver.Session import Util import Outputable import BasicTypes ( TypeOrKind(..) ) import qualified GHC.LanguageExtensions as LangExt +import Data.List ( sortBy ) import Control.Monad( unless )+import Data.Function ( on )  {- ************************************************************************@@ -844,7 +846,7 @@   = setSrcSpan (getSrcSpan (head sorted)) $     addErr (hang herald 2 (pprInstances sorted))  where-   sorted = sortWith getSrcLoc ispecs-   -- The sortWith just arranges that instances are displayed in order+   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
compiler/typecheck/TcAnnotations.hs view
@@ -5,7 +5,6 @@ \section[TcAnnotations]{Typechecking annotations} -} -{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies #-} @@ -15,7 +14,7 @@  import {-# SOURCE #-} TcSplice ( runAnnotation ) import Module-import DynFlags+import GHC.Driver.Session import Control.Monad ( when )  import GHC.Hs@@ -24,17 +23,17 @@ import TcRnMonad import SrcLoc import Outputable+import GHC.Driver.Types --- 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)+-- 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-  dflags <- getDynFlags-  case gopt Opt_ExternalInterpreter dflags of-    True  -> tcAnnotations' anns-    False -> warnAnns anns+  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 []@@ -43,13 +42,6 @@              (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
compiler/typecheck/TcArrows.hs view
@@ -30,7 +30,6 @@ import TcEvidence import Id( mkLocalId ) import Inst-import Name import TysWiredIn import VarSet import TysPrim@@ -161,14 +160,14 @@     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'+tc_cmd env (HsCmdIf x NoSyntaxExprRn 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')+        ; return (HsCmdIf x NoSyntaxExprTc pred' b1' b2')     } -tc_cmd env (HsCmdIf x (Just fun) pred b1 b2) res_ty -- Rebindable syntax for if+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@@ -184,7 +183,7 @@          ; b1'   <- tcCmd env b1 res_ty         ; b2'   <- tcCmd env b2 res_ty-        ; return (HsCmdIf x (Just fun') pred' b1' b2')+        ; return (HsCmdIf x fun' pred' b1' b2')     }  -------------------------------------------@@ -267,7 +266,7 @@         ; return (mkHsCmdWrap (mkWpCastN co) cmd') }   where     n_pats     = length pats-    match_ctxt = (LambdaExpr :: HsMatchContext Name)    -- Maybe KappaExpr?+    match_ctxt = (LambdaExpr :: HsMatchContext GhcRn)    -- Maybe KappaExpr?     pg_ctxt    = PatGuard match_ctxt      tc_grhss (GRHSs x grhss (L l binds)) stk_ty res_ty
compiler/typecheck/TcBackpack.hs view
@@ -20,9 +20,9 @@ import GhcPrelude  import BasicTypes (defaultFixity, TypeOrKind(..))-import Packages+import GHC.Driver.Packages import TcRnExports-import DynFlags+import GHC.Driver.Session import GHC.Hs import RdrName import TcRnMonad@@ -46,7 +46,7 @@ import NameSet import Avail import SrcLoc-import HscTypes+import GHC.Driver.Types import Outputable import Type import FastString@@ -58,9 +58,9 @@ import PrelNames import qualified Data.Map as Map -import Finder+import GHC.Driver.Finder import UniqDSet-import NameShape+import GHC.Types.Name.Shape import TcErrors import TcUnify import GHC.Iface.Rename@@ -168,9 +168,8 @@                          -- info for the *specific* name we matched.                          -> getLoc e                        _ -> nameSrcSpan name-            dflags <- getDynFlags             addErrAt loc-                (badReexportedBootThing dflags False name name')+                (badReexportedBootThing False name name')       -- This should actually never happen, but whatever...       | otherwise =         addErrAt (nameSrcSpan name)@@ -270,7 +269,7 @@  findExtraSigImports' _ _ _ = return emptyUniqDSet --- | 'findExtraSigImports', but in a convenient form for "GhcMake" and+-- | 'findExtraSigImports', but in a convenient form for "GHC.Driver.Make" and -- "TcRnDriver". findExtraSigImports :: HscEnv -> HscSource -> ModuleName                     -> IO [(Maybe FastString, Located ModuleName)]@@ -280,7 +279,7 @@            | mod_name <- uniqDSetToList extra_requirements ]  -- A version of 'implicitRequirements'' which is more friendly--- for "GhcMake" and "TcRnDriver".+-- for "GHC.Driver.Make" and "TcRnDriver". implicitRequirements :: HscEnv                      -> [(Maybe FastString, Located ModuleName)]                      -> IO [(Maybe FastString, Located ModuleName)]
compiler/typecheck/TcBinds.hs view
@@ -20,9 +20,9 @@ import {-# SOURCE #-} TcMatches ( tcGRHSsPat, tcMatchesFun ) import {-# SOURCE #-} TcExpr  ( tcMonoExpr ) import {-# SOURCE #-} TcPatSyn ( tcPatSynDecl, tcPatSynBuilderBind )-import CoreSyn (Tickish (..))+import GHC.Core (Tickish (..)) import CostCentre (mkUserCC, CCFlavour(DeclCC))-import DynFlags+import GHC.Driver.Session import FastString import GHC.Hs import TcSigs@@ -301,7 +301,7 @@ -- 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) }+        ; concatMapM (addLocM tc_boot_sig) (filter isTypeLSig sigs) }   where     tc_boot_sig (TypeSig _ lnames hs_ty) = mapM f lnames       where@@ -713,8 +713,7 @@        ; tick <- funBindTicks nm_loc mono_id mod prag_sigs        ; let bind' = FunBind { fun_id      = L nm_loc mono_id                              , fun_matches = matches'-                             , fun_co_fn   = co_fn-                             , fun_ext     = placeHolderNamesTc+                             , fun_ext     = co_fn                              , fun_tick    = tick }               export = ABE { abe_ext   = noExtField@@ -1250,8 +1249,7 @@             -> TcM (LHsBinds GhcTcId, [MonoBindInfo]) tcMonoBinds is_rec sig_fn no_gen            [ L b_loc (FunBind { fun_id = L nm_loc name-                              , fun_matches = matches-                              , fun_ext = fvs })]+                              , fun_matches = matches })]                              -- Single function binding,   | NonRecursive <- is_rec   -- ...binder isn't mentioned in RHS   , Nothing <- sig_fn name   -- ...with no type signature@@ -1276,8 +1274,8 @@         ; mono_id <- newLetBndr no_gen name rhs_ty         ; return (unitBag $ L b_loc $                      FunBind { fun_id = L nm_loc mono_id,-                               fun_matches = matches', fun_ext = fvs,-                               fun_co_fn = co_fn, fun_tick = [] },+                               fun_matches = matches',+                               fun_ext = co_fn, fun_tick = [] },                   [MBI { mbi_poly_name = name                        , mbi_sig       = Nothing                        , mbi_mono_id   = mono_id }]) }@@ -1424,8 +1422,7 @@                                  matches (mkCheckExpType $ idType mono_id)         ; return ( FunBind { fun_id = L loc mono_id                            , fun_matches = matches'-                           , fun_co_fn = co_fn-                           , fun_ext = placeHolderNamesTc+                           , fun_ext = co_fn                            , fun_tick = [] } ) }  tcRhs (TcPatBind infos pat' grhss pat_ty)@@ -1438,7 +1435,7 @@         ; grhss' <- addErrCtxt (patMonoBindsCtxt pat' grhss) $                     tcGRHSsPat grhss pat_ty         ; return ( PatBind { pat_lhs = pat', pat_rhs = grhss'-                           , pat_ext = NPatBindTc placeHolderNamesTc pat_ty+                           , pat_ext = NPatBindTc emptyNameSet pat_ty                            , pat_ticks = ([],[]) } )}  tcExtendTyVarEnvForRhs :: Maybe TcIdSigInst -> TcM a -> TcM a
compiler/typecheck/TcCanonical.hs view
@@ -27,7 +27,7 @@ import TyCon import TyCoRep   -- cleverly decomposes types, good for completeness checking import Coercion-import CoreSyn+import GHC.Core import Id( idType, mkTemplateLocals ) import FamInstEnv ( FamInstEnvs ) import FamInst ( tcTopNormaliseNewTypeTF_maybe )@@ -36,7 +36,7 @@ import VarSet( delVarSetList ) import OccName ( OccName ) import Outputable-import DynFlags( DynFlags )+import GHC.Driver.Session( DynFlags ) import NameSet import RdrName import GHC.Hs.Types( HsIPName(..) )@@ -96,8 +96,8 @@                                   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)+      ForAllPred tvs theta p -> do traceTcS "canEvNC:forall" (ppr pred)+                                   canForAllNC ev tvs theta p   where     pred = ctEvPred ev @@ -373,6 +373,10 @@ 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:@@ -438,6 +442,46 @@  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]@@ -483,32 +527,50 @@ -- 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)) $+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 evar given_loc sel_id+    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 $-                         (given_ty, mk_sc_sel evar sel_id)+                         mk_given_desc sel_id sc_pred            ; 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)+      -- 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` 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@@ -743,9 +805,23 @@ quantified constraint in its type if it is given an explicit type signature. -Note that we implement -} +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@@ -760,14 +836,14 @@     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+           ForAllPred tvs theta pred+              -> solveForAll new_ev tvs theta pred pend_sc            _  -> pprPanic "canForAll" (ppr new_ev)     } } -solveForAll :: CtEvidence -> [TyVarBinder] -> TcThetaType -> PredType -> Bool+solveForAll :: CtEvidence -> [TyVar] -> TcThetaType -> PredType -> Bool             -> TcS (StopOrContinue Ct)-solveForAll ev tv_bndrs theta pred pend_sc+solveForAll ev tvs theta pred pend_sc   | CtWanted { ctev_dest = dest } <- ev   = -- See Note [Solving a Wanted forall-constraint]     do { let skol_info = QuantCtxtSkol@@ -794,10 +870,10 @@        ; stopWith ev "Given forall-constraint" }    | otherwise-  = stopWith ev "Derived forall-constraint"+  = do { traceTcS "discarding derived forall-constraint" (ppr ev)+       ; 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 } @@ -2076,36 +2152,8 @@                                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]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+{- Note [Equalities with incompatible kinds]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ What do we do when we have an equality    (tv :: k1) ~ (rhs :: k2)
compiler/typecheck/TcClassDcl.hs view
@@ -37,11 +37,11 @@ import TcOrigin import TcType import TcRnMonad-import DriverPhases (HscSource(..))+import GHC.Driver.Phases (HscSource(..)) import BuildTyCl( TcMethInfo ) import Class import Coercion ( pprCoAxiom )-import DynFlags+import GHC.Driver.Session import FamInst import FamInstEnv import Id@@ -115,11 +115,11 @@ tcClassSigs clas sigs def_methods   = do { traceTc "tcClassSigs 1" (ppr clas) -       ; gen_dm_prs <- concat <$> mapM (addLocM tc_gen_sig) gen_sigs+       ; 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 <- concat <$> mapM (addLocM (tc_sig gen_dm_env)) vanilla_sigs+       ; op_info <- concatMapM (addLocM (tc_sig gen_dm_env)) vanilla_sigs         ; let op_names = mkNameSet [ n | (n,_,_) <- op_info ]        ; sequence_ [ failWithTc (badMethodErr clas n)
compiler/typecheck/TcDeriv.hs view
@@ -19,7 +19,7 @@ import GhcPrelude  import GHC.Hs-import DynFlags+import GHC.Driver.Session  import TcRnMonad import FamInst@@ -72,7 +72,7 @@ import Control.Monad import Control.Monad.Trans.Class import Control.Monad.Trans.Reader-import Data.List+import Data.List (partition, find)  {- ************************************************************************
compiler/typecheck/TcDerivInfer.hs view
@@ -50,7 +50,7 @@ import Control.Monad import Control.Monad.Trans.Class  (lift) import Control.Monad.Trans.Reader (ask)-import Data.List+import Data.List                  (sortBy) import Data.Maybe  ----------------------
compiler/typecheck/TcDerivUtils.hs view
@@ -29,9 +29,9 @@ import BasicTypes import Class import DataCon-import DynFlags+import GHC.Driver.Session import ErrUtils-import HscTypes (lookupFixity, mi_fix)+import GHC.Driver.Types (lookupFixity, mi_fix) import GHC.Hs import Inst import InstEnv
compiler/typecheck/TcEnv.hs view
@@ -3,8 +3,8 @@ {-# 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 UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow]+                                      -- in module GHC.Hs.Extension {-# LANGUAGE TypeFamilies #-}  module TcEnv(@@ -96,8 +96,8 @@ import NameSet import NameEnv import VarEnv-import HscTypes-import DynFlags+import GHC.Driver.Types+import GHC.Driver.Session import SrcLoc import BasicTypes hiding( SuccessFlag(..) ) import Module@@ -112,7 +112,7 @@ import Util ( HasDebugCallStack )  import Data.IORef-import Data.List+import Data.List (intercalate) import Control.Monad  {- *********************************************************************
compiler/typecheck/TcErrors.hs view
@@ -1,6 +1,7 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE LambdaCase #-}  {-# OPTIONS_GHC -Wno-incomplete-uni-patterns   #-} {-# OPTIONS_GHC -Wno-incomplete-record-updates #-}@@ -57,7 +58,7 @@ import FastString import Outputable import SrcLoc-import DynFlags+import GHC.Driver.Session import ListSetOps       ( equivClasses ) import Maybes import Pair@@ -809,31 +810,20 @@ 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+  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)  maybeReportHoleError :: ReportErrCtxt -> Ct -> ErrMsg -> TcM () -- Unlike maybeReportError, these "hole" errors are@@ -992,7 +982,7 @@ 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))+       ; mkErrDocAt (RealSrcSpan (tcl_loc tcl_env) Nothing)             (errDoc important [context] (relevant_bindings ++ valid_subs))        } @@ -1110,7 +1100,7 @@        ; imp_info <- getImports        ; curr_mod <- getModule        ; hpt <- getHpt-       ; mkErrDocAt (RealSrcSpan (tcl_loc lcl_env)) $+       ; 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)] }@@ -1196,10 +1186,8 @@            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+       = ppWhenOption sdocPrintExplicitCoercions $+           quotes (ppr tv) <+> text "is a coercion variable"  mkHoleError _ _ ct = pprPanic "mkHoleError" (ppr ct) @@ -1353,10 +1341,10 @@             where               sub_what = case sub_t_or_k of Just KindLevel -> text "kinds"                                             _              -> text "types"-              msg1 = sdocWithDynFlags $ \dflags ->+              msg1 = sdocOption sdocPrintExplicitCoercions $ \printExplicitCoercions ->                      case mb_cty2 of                        Just cty2-                         |  gopt Opt_PrintExplicitCoercions dflags+                         |  printExplicitCoercions                          || not (cty1 `pickyEqType` cty2)                          -> hang (text "When matching" <+> sub_what)                                2 (vcat [ ppr cty1 <+> dcolon <+>@@ -1762,8 +1750,7 @@     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+               , ((InferSkol prs, _) : _) <- getSkolemInfo (cec_encl ctxt) [tv]                = map fst prs                | otherwise                = []@@ -1922,10 +1909,9 @@                      -- 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"+                  , tcIsTyVarTy arg = sdocOption sdocPrintExplicitRuntimeReps $ \case+                                       True  -> text "kind" <+> quotes (ppr exp)+                                       False -> text "a type"                    | otherwise       = text "kind" <+> quotes (ppr exp) @@ -2348,9 +2334,9 @@          potential_msg           = ppWhen (not (null unifiers) && want_potential orig) $-            sdocWithDynFlags $ \dflags ->+            sdocOption sdocPrintPotentialInstances $ \print_insts ->             getPprStyle $ \sty ->-            pprPotentials dflags sty potential_hdr unifiers+            pprPotentials (PrintPotentialInstances print_insts) sty potential_hdr unifiers          potential_hdr           = vcat [ ppWhen lead_with_ambig $@@ -2409,9 +2395,9 @@                   sep [text "Matching givens (or their superclasses):"                       , nest 2 (vcat matching_givens)] -             ,  sdocWithDynFlags $ \dflags ->+             ,  sdocOption sdocPrintPotentialInstances $ \print_insts ->                 getPprStyle $ \sty ->-                pprPotentials dflags sty (text "Matching instances:") $+                pprPotentials (PrintPotentialInstances print_insts) sty (text "Matching instances:") $                 ispecs ++ unifiers               ,  ppWhen (null matching_givens && isSingleton matches && null unifiers) $@@ -2600,9 +2586,13 @@ show_fixes (f:fs) = sep [ text "Possible fix:"                         , nest 2 (vcat (f : map (text "or" <+>) fs))] -pprPotentials :: DynFlags -> PprStyle -> SDoc -> [ClsInst] -> SDoc++-- Avoid boolean blindness+newtype PrintPotentialInstances = PrintPotentialInstances Bool++pprPotentials :: PrintPotentialInstances -> PprStyle -> SDoc -> [ClsInst] -> SDoc -- See Note [Displaying potential instances]-pprPotentials dflags sty herald insts+pprPotentials (PrintPotentialInstances show_potentials) sty herald insts   | null insts   = empty @@ -2621,7 +2611,6 @@                , 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@@ -2755,11 +2744,13 @@ pprSkols ctxt tvs   = vcat (map pp_one (getSkolemInfo (cec_encl ctxt) tvs))   where-    pp_one (Implic { ic_info = skol_info }, tvs)-      | UnkSkol <- skol_info+    pp_one (UnkSkol, tvs)       = hang (pprQuotedList tvs)            2 (is_or_are tvs "an" "unknown")-      | otherwise+    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)@@ -2779,20 +2770,21 @@     dep_tkv_set = tyCoVarsOfTypes (map tyVarKind tkvs)  getSkolemInfo :: [Implication] -> [TcTyVar]-              -> [(Implication, [TcTyVar])]+              -> [(SkolemInfo, [TcTyVar])]                    -- #14628 -- Get the skolem info for some type variables--- from the implication constraints that bind them+-- from the implication constraints that bind them. ----- In the returned (implic, tvs) pairs, the 'tvs' part is non-empty+-- In the returned (skolem, tvs) pairs, the 'tvs' part is non-empty getSkolemInfo _ []   = []  getSkolemInfo [] tvs-  = pprPanic "No skolem info:" (ppr 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     = (implic, tvs_here) : getSkolemInfo implics tvs_other+  | 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 @@ -2944,7 +2936,7 @@ ~~~~~~~~~~~~~~~~~~~~~~ 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.+are created by in GHC.Runtime.Heap.Inspect.zonkRTTIType.  ************************************************************************ *                                                                      *
compiler/typecheck/TcEvTerm.hs view
@@ -8,15 +8,15 @@  import FastString import Type-import CoreSyn-import MkCore+import GHC.Core+import GHC.Core.Make import Literal ( Literal(..) ) import TcEvidence-import HscTypes-import DynFlags+import GHC.Driver.Types+import GHC.Driver.Session import Name import Module-import CoreUtils+import GHC.Core.Utils import PrelNames import SrcLoc
compiler/typecheck/TcExpr.hs view
@@ -69,7 +69,7 @@ import TysPrim( intPrimTy ) import PrimOp( tagToEnumKey ) import PrelNames-import DynFlags+import GHC.Driver.Session import SrcLoc import Util import VarEnv  ( emptyTidyEnv, mkInScopeSet )@@ -83,7 +83,7 @@ import qualified GHC.LanguageExtensions as LangExt  import Data.Function-import Data.List+import Data.List (partition, sortBy, groupBy, intersect) import qualified Data.Set as Set  {-@@ -440,7 +440,7 @@   = 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+               -- 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@@ -461,7 +461,7 @@        ; 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+                   -- See Note [Don't flatten tuples from HsSyn] in GHC.Core.Make         ; wrap <- tcSubTypeHR (Shouldn'tHappenOrigin "ExpTuple")                              (Just expr)@@ -534,7 +534,7 @@     match_ctxt = MC { mc_what = CaseAlt,                       mc_body = tcBody } -tcExpr (HsIf x Nothing pred b1 b2) res_ty    -- Ordinary 'if'+tcExpr (HsIf x NoSyntaxExprRn 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]@@ -542,9 +542,9 @@         ; b1' <- tcMonoExpr b1 res_ty        ; b2' <- tcMonoExpr b2 res_ty-       ; return (HsIf x Nothing pred' b1' b2') }+       ; return (HsIf x NoSyntaxExprTc pred' b1' b2') } -tcExpr (HsIf x (Just fun) pred b1 b2) res_ty+tcExpr (HsIf x fun@(SyntaxExprRn {}) pred b1 b2) res_ty   = do { ((pred', b1', b2'), fun')            <- tcSyntaxOp IfOrigin fun [SynAny, SynAny, SynAny] res_ty $               \ [pred_ty, b1_ty, b2_ty] ->@@ -552,7 +552,7 @@                  ; b1'   <- tcPolyExpr b1   b1_ty                  ; b2'   <- tcPolyExpr b2   b2_ty                  ; return (pred', b1', b2') }-       ; return (HsIf x (Just fun') pred' b1' b2') }+       ; return (HsIf x fun' pred' b1' b2') }  tcExpr (HsMultiIf _ alts) res_ty   = do { res_ty <- if isSingleton alts@@ -1081,10 +1081,6 @@ isHsValArg (HsTypeArg {}) = False isHsValArg (HsArgPar {})  = False -isHsTypeArg :: HsArg tm ty -> Bool-isHsTypeArg (HsTypeArg {}) = True-isHsTypeArg _              = False- isArgPar :: HsArg tm ty -> Bool isArgPar (HsArgPar {})  = True isArgPar (HsValArg {})  = False@@ -1219,14 +1215,6 @@        -> 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-  | fun_is_out_of_scope-  , any isHsTypeArg orig_args-  = failM  -- See Note [VTA for out-of-scope functions]-    -- We have /already/ emitted a CHoleCan constraint (in tcInferFun),-    -- which will later cough up a "Variable not in scope error", so-    -- we can simply fail now, avoiding a confusing error cascade--  | otherwise   = go [] 1 orig_fun_ty orig_args   where     -- Don't count visible type arguments when determining how many arguments@@ -1248,6 +1236,10 @@            }      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@@ -1338,18 +1330,24 @@ 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 reports 'wurble' as out of-scope, and tries to give its type.+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.  If so, we simply fail-immediately.  We've already inferred the type of the function,-so we'll /already/ have emitted a CHoleCan constraint; failing-preserves that constraint.+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. -A mild shortcoming of this approach is that we thereby-don't typecheck any of the arguments, but so be it.+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).@@ -1401,11 +1399,11 @@ --------------------------- -- See TcType.SyntaxOpType also for commentary tcSyntaxOp :: CtOrigin-           -> SyntaxExpr GhcRn+           -> SyntaxExprRn            -> [SyntaxOpType]           -- ^ shape of syntax operator arguments            -> ExpRhoType               -- ^ overall result type            -> ([TcSigmaType] -> TcM a) -- ^ Type check any arguments-           -> TcM (a, SyntaxExpr GhcTcId)+           -> TcM (a, SyntaxExprTc) -- ^ Typecheck a syntax operator -- The operator is a variable or a lambda at this stage (i.e. renamer -- output)@@ -1415,21 +1413,22 @@ -- | 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+              -> SyntaxExprRn               -> [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+              -> TcM (a, SyntaxExprTc)+tcSyntaxOpGen orig (SyntaxExprRn op) arg_tys res_ty thing_inside+  = do { (expr, sigma) <- tcInferSigma $ noLoc 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 }) }+       ; return (result, SyntaxExprTc { syn_expr = mkHsWrap expr_wrap $ unLoc expr+                                      , syn_arg_wraps = arg_wraps+                                      , syn_res_wrap  = res_wrap }) }+tcSyntaxOpGen _ NoSyntaxExprRn _ _ _ = panic "tcSyntaxOpGen"  {- Note [tcSynArg]
compiler/typecheck/TcExpr.hs-boot view
@@ -1,6 +1,6 @@ module TcExpr where import Name-import GHC.Hs    ( HsExpr, LHsExpr, SyntaxExpr )+import GHC.Hs    ( HsExpr, LHsExpr, SyntaxExprRn, SyntaxExprTc ) import TcType   ( TcRhoType, TcSigmaType, SyntaxOpType, ExpType, ExpRhoType ) import TcRnTypes( TcM ) import TcOrigin ( CtOrigin )@@ -25,18 +25,18 @@        -> TcM (LHsExpr GhcTcId, TcRhoType)  tcSyntaxOp :: CtOrigin-           -> SyntaxExpr GhcRn+           -> SyntaxExprRn            -> [SyntaxOpType]           -- ^ shape of syntax operator arguments            -> ExpType                  -- ^ overall result type            -> ([TcSigmaType] -> TcM a) -- ^ Type check any arguments-           -> TcM (a, SyntaxExpr GhcTcId)+           -> TcM (a, SyntaxExprTc)  tcSyntaxOpGen :: CtOrigin-              -> SyntaxExpr GhcRn+              -> SyntaxExprRn               -> [SyntaxOpType]               -> SyntaxOpType               -> ([TcSigmaType] -> TcM a)-              -> TcM (a, SyntaxExpr GhcTcId)+              -> TcM (a, SyntaxExprTc)   tcCheckId :: Name -> ExpRhoType -> TcM (HsExpr GhcTcId)
compiler/typecheck/TcForeign.hs view
@@ -55,12 +55,12 @@ import TyCon import TcType import PrelNames-import DynFlags+import GHC.Driver.Session import Outputable import GHC.Platform import SrcLoc import Bag-import Hooks+import GHC.Driver.Hooks import qualified GHC.LanguageExtensions as LangExt  import Control.Monad
compiler/typecheck/TcGenDeriv.hs view
@@ -50,7 +50,7 @@ import Fingerprint import Encoding -import DynFlags+import GHC.Driver.Session import PrelInfo import FamInst import FamInstEnv
compiler/typecheck/TcGenFunctor.hs view
@@ -224,7 +224,7 @@                  , ft_co_var = panic "contravariant in ft_replace" }      -- Con a1 a2 ... -> Con (f1 a1) (f2 a2) ...-    match_for_con :: HsMatchContext RdrName+    match_for_con :: HsMatchContext GhcPs                   -> [LPat GhcPs] -> DataCon -> [LHsExpr GhcPs]                   -> State [RdrName] (LMatch GhcPs (LHsExpr GhcPs))     match_for_con ctxt = mkSimpleConMatch ctxt $@@ -463,7 +463,7 @@ -- 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+mkSimpleConMatch :: Monad m => HsMatchContext GhcPs                  -> (RdrName -> [LHsExpr GhcPs] -> m (LHsExpr GhcPs))                  -> [LPat GhcPs]                  -> DataCon@@ -499,7 +499,7 @@ -- -- See Note [Generated code for DeriveFoldable and DeriveTraversable] mkSimpleConMatch2 :: Monad m-                  => HsMatchContext RdrName+                  => HsMatchContext GhcPs                   -> (LHsExpr GhcPs -> [LHsExpr GhcPs]                                       -> m (LHsExpr GhcPs))                   -> [LPat GhcPs]
compiler/typecheck/TcGenGenerics.hs view
@@ -38,7 +38,7 @@ import PrelNames import TcEnv import TcRnMonad-import HscTypes+import GHC.Driver.Types import ErrUtils( Validity(..), andValid ) import SrcLoc import Bag
compiler/typecheck/TcHoleErrors.hs view
@@ -37,7 +37,7 @@ import Util import TcEnv (tcLookup) import Outputable-import DynFlags+import GHC.Driver.Session import Maybes import FV ( fvVarList, fvVarSet, unionFV, mkFVs, FV ) @@ -51,10 +51,10 @@ import TcSimplify    ( simpl_top, runTcSDeriveds ) import TcUnify       ( tcSubType_NC ) -import ExtractDocs ( extractDocs )+import GHC.HsToCore.Docs ( extractDocs ) import qualified Data.Map as Map import GHC.Hs.Doc      ( unpackHDS, DeclDocMap(..) )-import HscTypes        ( ModIface_(..) )+import GHC.Driver.Types        ( ModIface_(..) ) import GHC.Iface.Load  ( loadInterfaceForNameMaybe )  import PrelInfo (knownKeyNames)
compiler/typecheck/TcHsSyn.hs view
@@ -36,7 +36,7 @@         zonkTopBndrs,         ZonkEnv, ZonkFlexi(..), emptyZonkEnv, mkEmptyZonkEnv, initZonkEnv,         zonkTyVarBinders, zonkTyVarBindersX, zonkTyVarBinderX,-        zonkTyBndrs, zonkTyBndrsX, zonkRecTyVarBndrs,+        zonkTyBndrs, zonkTyBndrsX,         zonkTcTypeToType,  zonkTcTypeToTypeX,         zonkTcTypesToTypes, zonkTcTypesToTypesX,         zonkTyVarOcc,@@ -69,12 +69,12 @@ import Coercion import ConLike import DataCon-import HscTypes+import GHC.Driver.Types import Name import NameEnv import Var import VarEnv-import DynFlags+import GHC.Driver.Session import Literal import BasicTypes import Maybes@@ -83,7 +83,7 @@ import Outputable import Util import UniqFM-import CoreSyn+import GHC.Core  import {-# SOURCE #-} TcSplice (runTopSplice) @@ -115,7 +115,7 @@ 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+                  -- See Note [Don't flatten tuples from HsSyn] in GHC.Core.Make hsPatType (SumPat tys _ _ _ )           = mkSumTy tys hsPatType (ConPatOut { pat_con = lcon                      , pat_arg_tys = tys })@@ -327,20 +327,14 @@   where     (tycovars, ids) = partition isTyCoVar vars -extendIdZonkEnv1 :: ZonkEnv -> Var -> ZonkEnv-extendIdZonkEnv1 ze@(ZonkEnv { ze_id_env = id_env }) id+extendIdZonkEnv :: ZonkEnv -> Var -> ZonkEnv+extendIdZonkEnv ze@(ZonkEnv { ze_id_env = id_env }) id   = ze { ze_id_env = extendVarEnv id_env id id } -extendTyZonkEnv1 :: ZonkEnv -> TyVar -> ZonkEnv-extendTyZonkEnv1 ze@(ZonkEnv { ze_tv_env = ty_env }) tv+extendTyZonkEnv :: ZonkEnv -> TyVar -> ZonkEnv+extendTyZonkEnv ze@(ZonkEnv { ze_tv_env = ty_env }) tv   = ze { ze_tv_env = extendVarEnv ty_env tv tv } -extendTyZonkEnvN :: ZonkEnv -> [(Name,TyVar)] -> ZonkEnv-extendTyZonkEnvN ze@(ZonkEnv { ze_tv_env = ty_env }) pairs-  = ze { ze_tv_env = foldl add ty_env pairs }-  where-    add env (name, tv) = extendVarEnv_Directly env (getUnique name) tv- setZonkType :: ZonkEnv -> ZonkFlexi -> ZonkEnv setZonkType ze flexi = ze { ze_flexi = flexi } @@ -429,7 +423,7 @@ zonkCoreBndrX :: ZonkEnv -> Var -> TcM (ZonkEnv, Var) zonkCoreBndrX env v   | isId v = do { v' <- zonkIdBndr env v-                ; return (extendIdZonkEnv1 env v', v') }+                ; return (extendIdZonkEnv env v', v') }   | otherwise = zonkTyBndrX env v  zonkCoreBndrsX :: ZonkEnv -> [Var] -> TcM (ZonkEnv, [Var])@@ -444,12 +438,16 @@ 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 (extendTyZonkEnv1 env tv', tv') }+       ; return (extendTyZonkEnv env tv', tv') }  zonkTyVarBinders ::  [VarBndr TcTyVar vis]                  -> TcM (ZonkEnv, [VarBndr TyVar vis])@@ -466,22 +464,6 @@   = do { (env', tv') <- zonkTyBndrX env tv        ; return (env', Bndr tv' vis) } -zonkRecTyVarBndrs :: [Name] -> [TcTyVar] -> TcM (ZonkEnv, [TyVar])--- This rather specialised function is used in exactly one place.--- See Note [Tricky scoping in generaliseTcTyCon] in TcTyClsDecls.-zonkRecTyVarBndrs names tc_tvs-  = initZonkEnv $ \ ze ->-    fixM $ \ ~(_, rec_new_tvs) ->-    do { let ze' = extendTyZonkEnvN ze $-                   zipWithLazy (\ tc_tv new_tv -> (getName tc_tv, new_tv))-                               tc_tvs rec_new_tvs-       ; new_tvs <- zipWithM (zonk_one ze') names tc_tvs-       ; return (ze', new_tvs) }-  where-    zonk_one ze name tc_tv-      = do { ki <- zonkTcTypeToTypeX ze (tyVarKind tc_tv)-           ; return (mkTyVar name ki) }- zonkTopExpr :: HsExpr GhcTcId -> TcM (HsExpr GhcTc) zonkTopExpr e = initZonkEnv $ \ ze -> zonkExpr ze e @@ -581,13 +563,13 @@  zonk_bind env bind@(FunBind { fun_id = L loc var                             , fun_matches = ms-                            , fun_co_fn = co_fn })+                            , 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_co_fn = new_co_fn }) }+                      , fun_ext = new_co_fn }) }  zonk_bind env (AbsBinds { abs_tvs = tyvars, abs_ev_vars = evs                         , abs_ev_binds = ev_binds@@ -614,7 +596,7 @@       | has_sig       , (L loc bind@(FunBind { fun_id      = L mloc mono_id                              , fun_matches = ms-                             , fun_co_fn   = co_fn })) <- lbind+                             , fun_ext     = 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@@ -623,7 +605,7 @@            ; return $ L loc $              bind { fun_id      = L mloc new_mono_id                   , fun_matches = new_ms-                  , fun_co_fn   = new_co_fn } }+                  , fun_ext     = new_co_fn } }       | otherwise       = zonk_lbind env lbind   -- The normal case @@ -813,7 +795,7 @@     zonk_b env' (PendingTcSplice n e) = do e' <- zonkLExpr env' e                                            return (PendingTcSplice n e') -zonkExpr env (HsSpliceE _ (HsSplicedT s)) =+zonkExpr env (HsSpliceE _ (XSplice (HsSplicedT s))) =   runTopSplice s >>= zonkExpr env  zonkExpr _ (HsSpliceE x s) = WARN( True, ppr s ) -- Should not happen@@ -865,18 +847,12 @@        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)+zonkExpr env (HsIf x 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)+       return (HsIf x new_fun new_e1 new_e2 new_e3)  zonkExpr env (HsMultiIf ty alts)   = do { alts' <- mapM (wrapLocM zonk_alt) alts@@ -954,10 +930,10 @@ zonkExpr env (HsStatic fvs expr)   = HsStatic fvs <$> zonkLExpr env expr -zonkExpr env (HsWrap x co_fn expr)+zonkExpr env (XExpr (HsWrap 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)+       return (XExpr (HsWrap new_co_fn new_expr))  zonkExpr _ e@(HsUnboundVar {})   = return e@@ -988,15 +964,16 @@ -- See Note [Skolems in zonkSyntaxExpr] zonkSyntaxExpr :: ZonkEnv -> SyntaxExpr GhcTcId                -> TcM (ZonkEnv, SyntaxExpr GhcTc)-zonkSyntaxExpr env (SyntaxExpr { syn_expr      = expr+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, SyntaxExpr { syn_expr      = expr'-                                  , syn_arg_wraps = arg_wraps'-                                  , syn_res_wrap  = res_wrap' }) }+       ; return (env1, SyntaxExprTc { syn_expr      = expr'+                                    , syn_arg_wraps = arg_wraps'+                                    , syn_res_wrap  = res_wrap' }) }+zonkSyntaxExpr env NoSyntaxExprTc = return (env, NoSyntaxExprTc)  ------------------------------------------------------------------------- @@ -1005,10 +982,10 @@  zonkLCmd  env cmd  = wrapLocM (zonkCmd env) cmd -zonkCmd env (HsCmdWrap x w cmd)+zonkCmd env (XCmd (HsWrap w cmd))   = do { (env1, w') <- zonkCoFn env w        ; cmd' <- zonkCmd env1 cmd-       ; return (HsCmdWrap x w' 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@@ -1039,14 +1016,11 @@        return (HsCmdCase x new_expr new_ms)  zonkCmd env (HsCmdIf x eCond ePred cThen cElse)-  = do { (env1, new_eCond) <- zonkWit env eCond+  = 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) }-  where-    zonkWit env Nothing  = return (env, Nothing)-    zonkWit env (Just w) = second Just <$> zonkSyntaxExpr env w  zonkCmd env (HsCmdLet x (L l binds) cmd)   = do (new_env, new_binds) <- zonkLocalBinds env binds@@ -1058,10 +1032,8 @@        new_ty <- zonkTcTypeToTypeX env ty        return (HsCmdDo new_ty (L l new_stmts)) -zonkCmd _ (XCmd nec) = noExtCon nec  - zonkCmdTop :: ZonkEnv -> LHsCmdTop GhcTcId -> TcM (LHsCmdTop GhcTc) zonkCmdTop env cmd = wrapLocM (zonk_cmd_top env) cmd @@ -1357,7 +1329,7 @@  zonk_pat env (VarPat x (L l v))   = do  { v' <- zonkIdBndr env v-        ; return (extendIdZonkEnv1 env v', VarPat x (L l v')) }+        ; return (extendIdZonkEnv env v', VarPat x (L l v')) }  zonk_pat env (LazyPat x pat)   = do  { (env', pat') <- zonkPat env pat@@ -1369,7 +1341,7 @@  zonk_pat env (AsPat x (L loc v) pat)   = do  { v' <- zonkIdBndr env v-        ; (env', pat') <- zonkPat (extendIdZonkEnv1 env v') pat+        ; (env', pat') <- zonkPat (extendIdZonkEnv env v') pat         ; return (env', AsPat x (L loc v') pat') }  zonk_pat env (ViewPat ty expr pat)@@ -1459,7 +1431,7 @@         ; lit1' <- zonkOverLit env2 lit1         ; lit2' <- zonkOverLit env2 lit2         ; ty' <- zonkTcTypeToTypeX env2 ty-        ; return (extendIdZonkEnv1 env2 n',+        ; return (extendIdZonkEnv env2 n',                   NPlusKPat ty' (L loc n') (L l lit1') lit2' e1' e2') }  zonk_pat env (CoPat x co_fn pat ty)@@ -1607,7 +1579,7 @@     = do scrut' <- zonkCoreExpr env scrut          ty' <- zonkTcTypeToTypeX env ty          b' <- zonkIdBndr env b-         let env1 = extendIdZonkEnv1 env b'+         let env1 = extendIdZonkEnv env b'          alts' <- mapM (zonkCoreAlt env1) alts          return $ Case scrut' b' ty' alts' @@ -1621,7 +1593,7 @@ zonkCoreBind env (NonRec v e)     = do v' <- zonkIdBndr env v          e' <- zonkCoreExpr env e-         let env1 = extendIdZonkEnv1 env v'+         let env1 = extendIdZonkEnv env v'          return (env1, NonRec v' e') zonkCoreBind env (Rec pairs)     = do (env1, pairs') <- fixM go@@ -1923,7 +1895,7 @@ --------------------------------------- {- Note [Zonking the LHS of a RULE] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-See also DsBinds Note [Free tyvars on rule LHS]+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:@@ -1946,7 +1918,7 @@   ZonkEnv.  (This is in fact the whole reason that the ZonkEnv has a   UnboundTyVarZonker.) -* In DsBinds, we quantify over it.  See DsBinds+* 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)
compiler/typecheck/TcHsType.hs view
@@ -113,7 +113,7 @@ import Outputable import FastString import PrelNames hiding ( wildCardName )-import DynFlags+import GHC.Driver.Session import qualified GHC.LanguageExtensions as LangExt  import Maybes@@ -1701,33 +1701,8 @@ %*                                                                      * %************************************************************************ -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]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+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,@@ -1758,10 +1733,10 @@  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.+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@@ -2009,11 +1984,10 @@                --                -- mkAnonTyConBinder: see Note [No polymorphic recursion] -             all_tv_prs = (kv_ns                `zip` scoped_kvs) ++-                          (hsLTyVarNames hs_tvs `zip` tc_tvs)-               -- NB: bindIplicitTKBndrs_Q_Tv makes /freshly-named/ unification-               --     variables, hence the need to zip here.  Ditto bindExplicit..-               -- See TcMType Note [Unification variables need fresh Names]+             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@@ -2039,98 +2013,102 @@   -> 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 ktvs kc_res_ki =-  addTyConFlavCtxt name flav $-    pushTcLevelM_ $-    solveEqualities $  -- #16687-    bind_implicit (hsq_ext ktvs) $ \implicit_tcv_prs -> 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 (hsq_explicit ktvs)--      -- 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)+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 -      -- 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+          -- 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) -      tcExtendNameTyVarEnv explicit_tv_prs $ do+          -- 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 -        -- 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+        ; (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'.-        m_res_ki <- kc_res_ki >>= \ctx_k ->-          case ctx_k of-            AnyKind -> return Nothing-            _ -> Just <$> newExpectedKind ctx_k+                     -- 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+                     -- 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 -        -- Convert each invisible TyCoBinder to TyConBinder for tyConBinders.-        invis_tcbs <- mapM invis_to_tcb invis_binders+                     -- 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 -        -- 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_tv_prs <- mapSndM zonkTcTyVarToTyVar implicit_tcv_prs+        ; 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-            all_tv_prs = implicit_tv_prs ++ explicit_tv_prs-            tc = mkTcTyCon name tcbs r_ki all_tv_prs True flav+        ; 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+        ; traceTc "kcCheckDeclHeader_sig done:" $ vcat           [ text "tyConName = " <+> ppr (tyConName tc)           , text "kisig =" <+> debugPprType kisig           , text "tyConKind =" <+> debugPprType (tyConKind tc)@@ -2138,7 +2116,7 @@           , text "tcTyConScopedTyVars" <+> ppr (tcTyConScopedTyVars tc)           , text "tyConResKind" <+> debugPprType (tyConResKind tc)           ]-        return tc+        ; return tc }   where     -- Consider this declaration:     --@@ -2208,14 +2186,6 @@       MASSERT(null stv)       return tcb -    -- similar to:  bindImplicitTKBndrs_Tv-    bind_implicit :: [Name] -> ([(Name,TcTyVar)] -> TcM a) -> TcM a-    bind_implicit tv_names thing_inside =-      do { let new_tv name = do { tcv <- newFlexiKindedTyVarTyVar name-                                ; return (name, tcv) }-         ; tcvs <- mapM new_tv tv_names-         ; tcExtendNameTyVarEnv tcvs (thing_inside tcvs) }-     -- 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 ()@@ -2245,6 +2215,8 @@           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))@@ -2578,6 +2550,56 @@ *                                                                      * ********************************************************************* -} +{- 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 --------------------------------------@@ -2585,10 +2607,12 @@ bindImplicitTKBndrs_Skol, bindImplicitTKBndrs_Tv,   bindImplicitTKBndrs_Q_Skol, bindImplicitTKBndrs_Q_Tv   :: [Name] -> TcM a -> TcM ([TcTyVar], a)-bindImplicitTKBndrs_Skol   = bindImplicitTKBndrsX newFlexiKindedSkolemTyVar-bindImplicitTKBndrs_Tv     = bindImplicitTKBndrsX newFlexiKindedTyVarTyVar 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@@ -2621,8 +2645,11 @@  newFlexiKindedTyVarTyVar :: Name -> TcM TyVar newFlexiKindedTyVarTyVar = newFlexiKindedTyVar newTyVarTyVar-   -- See Note [Unification variables need fresh Names] in TcMType +cloneFlexiKindedTyVarTyVar :: Name -> TcM TyVar+cloneFlexiKindedTyVarTyVar = newFlexiKindedTyVar cloneTyVarTyVar+   -- See Note [Cloning for tyvar binders]+ -------------------------------------- -- Explicit binders --------------------------------------@@ -2633,7 +2660,9 @@     -> TcM ([TcTyVar], a)  bindExplicitTKBndrs_Skol = bindExplicitTKBndrsX (tcHsTyVarBndr newSkolemTyVar)-bindExplicitTKBndrs_Tv   = bindExplicitTKBndrsX (tcHsTyVarBndr newTyVarTyVar)+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@@ -2643,7 +2672,9 @@  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]@@ -2662,7 +2693,7 @@             -- 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 [Unification variables need fresh Names]+            -- See TcMType Note [Cloning for tyvar binders]             ; (tvs,res) <- tcExtendNameTyVarEnv [(hsTyVarName hs_tv, tv)] $                            go hs_tvs             ; return (tv:tvs, res) }@@ -2670,7 +2701,6 @@ ----------------- tcHsTyVarBndr :: (Name -> Kind -> TcM TyVar)               -> HsTyVarBndr GhcRn -> TcM TcTyVar--- Returned TcTyVar has the same name; no cloning tcHsTyVarBndr new_tv (UserTyVar _ (L _ tv_nm))   = do { kind <- newMetaKindVar        ; new_tv tv_nm kind }
compiler/typecheck/TcInstDcls.hs view
@@ -44,9 +44,9 @@ import TcEnv import TcHsType import TcUnify-import CoreSyn    ( Expr(..), mkApps, mkVarApps, mkLams )-import MkCore     ( nO_METHOD_BINDING_ERROR_ID )-import CoreUnfold ( mkInlineUnfoldingWithArity, mkDFunUnfolding )+import GHC.Core        ( Expr(..), mkApps, mkVarApps, mkLams )+import GHC.Core.Make   ( nO_METHOD_BINDING_ERROR_ID )+import GHC.Core.Unfold ( mkInlineUnfoldingWithArity, mkDFunUnfolding ) import Type import TcEvidence import TyCon@@ -59,7 +59,7 @@ import VarSet import Bag import BasicTypes-import DynFlags+import GHC.Driver.Session import ErrUtils import FastString import Id@@ -163,7 +163,7 @@   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+  unfoldings. See Note [RULEs enabled in InitialPhase] in SimplUtils  Note [ClassOp/DFun selection] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -189,7 +189,7 @@  * We give 'df' a magical unfolding (DFunUnfolding [$cop1, $cop2, ..])    that lists its methods. - * We make CoreUnfold.exprIsConApp_maybe spot a DFunUnfolding and return+ * We make GHC.Core.Unfold.exprIsConApp_maybe spot a DFunUnfolding and return    a suitable constructor application -- inlining df "on the fly" as it    were. @@ -1163,7 +1163,7 @@    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+                 -- See Note [Levity polymorphism checking] in GHC.HsToCore.Monad    dict_args  = map Type inst_tys ++                 [mkVarApps (Var id) dfun_bndrs | id <- sc_meth_ids] @@ -1174,7 +1174,7 @@    [dict_con]  = tyConDataCons clas_tc    is_newtype  = isNewTyCon clas_tc -wrapId :: HsWrapper -> IdP (GhcPass id) -> HsExpr (GhcPass id)+wrapId :: HsWrapper -> Id -> HsExpr GhcTc wrapId wrapper id = mkHsWrap wrapper (HsVar noExtField (noLoc id))  {- Note [Typechecking plan for instance declarations]
compiler/typecheck/TcInteract.hs view
@@ -45,7 +45,7 @@ import Bag import MonadUtils ( concatMapM, foldlM ) -import CoreSyn+import GHC.Core import Data.List( partition, deleteFirstsBy ) import SrcLoc import VarEnv@@ -54,7 +54,7 @@ import Maybes( isJust ) import Pair (Pair(..)) import Unique( hasKey )-import DynFlags+import GHC.Driver.Session import Util import qualified GHC.LanguageExtensions as LangExt @@ -2655,15 +2655,19 @@ matchLocalInst pred loc   = do { ics <- getInertCans        ; case match_local_inst (inert_insts ics) of-           ([], False) -> return NoInstance+           ([], 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-                   ; return $ OneInst { cir_new_theta = theta-                                      , cir_mk_ev     = evDFunApp dfun_id tys-                                      , cir_what      = LocalInstance } }-           _ -> return NotSure }+                   ; 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
compiler/typecheck/TcMType.hs view
@@ -57,7 +57,8 @@   -- Instantiation   newMetaTyVars, newMetaTyVarX, newMetaTyVarsX,   newMetaTyVarTyVars, newMetaTyVarTyVarX,-  newTyVarTyVar, newPatSigTyVar, newSkolemTyVar, newWildCardX,+  newTyVarTyVar, cloneTyVarTyVar,+  newPatSigTyVar, newSkolemTyVar, newWildCardX,   tcInstType,   tcInstSkolTyVars, tcInstSkolTyVarsX, tcInstSkolTyVarsAt,   tcSkolDFunType, tcSuperSkolTyVars, tcInstSuperSkolTyVarsX,@@ -125,7 +126,7 @@ import Bag import Pair import UniqSet-import DynFlags+import GHC.Driver.Session import qualified GHC.LanguageExtensions as LangExt import BasicTypes ( TypeOrKind(..) ) @@ -707,30 +708,6 @@ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ At the moment we give a unification variable a System Name, which influences the way it is tidied; see TypeRep.tidyTyVarBndr.--Note [Unification variables need fresh Names]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Whenever we allocate a unification variable (MetaTyVar) we give-it a fresh name.   #16221 is a very tricky case that illustrates-why this is important:--   data SameKind :: k -> k -> *-   data T0 a = forall k2 (b :: k2). MkT0 (SameKind a b) !Int--When kind-checking T0, we give (a :: kappa1). Then, in kcConDecl-we allocate a unification variable kappa2 for k2, and then we-end up unifying kappa1 := kappa2 (because of the (SameKind a b).--Now we generalise over kappa2; but if kappa2's Name is k2,-we'll end up giving T0 the kind forall k2. k2 -> *.  Nothing-directly wrong with that but when we typecheck the data constrautor-we end up giving it the type-  MkT0 :: forall k1 (a :: k1) k2 (b :: k2).-          SameKind @k2 a b -> Int -> T0 @{k2} a-which is bogus.  The result type should be T0 @{k1} a.--And there no reason /not/ to clone the Name when making a-unification variable.  So that's what we do. -}  metaInfoToTyVarName :: MetaInfo -> FastString@@ -762,9 +739,18 @@  newTyVarTyVar :: Name -> Kind -> TcM TcTyVar -- See Note [TyVarTv]--- See Note [Unification variables need fresh Names]+-- 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@@ -772,7 +758,7 @@          -- 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 "newTyVarTyVar" (ppr tyvar)+       ; traceTc "cloneTyVarTyVar" (ppr tyvar)        ; return tyvar }  newPatSigTyVar :: Name -> Kind -> TcM TcTyVar@@ -1315,11 +1301,11 @@     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 }+      | 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)@@ -1408,7 +1394,6 @@     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@@ -1753,16 +1738,17 @@ skolemiseUnboundMetaTyVar tv   = ASSERT2( isMetaTyVar tv, ppr tv )     do  { when debugIsOn (check_empty tv)-        ; span <- getSrcSpanM    -- Get the location from "here"+        ; here <- getSrcSpanM    -- Get the location from "here"                                  -- ie where we are generalising         ; kind <- zonkTcType (tyVarKind tv)-        ; let uniq        = getUnique tv-                -- NB: Use same Unique as original tyvar. This is-                -- convenient in reading dumps, but is otherwise inessential.--              tv_name     = getOccName tv-              final_name  = mkInternalName uniq tv_name span-              final_tv    = mkTcTyVar final_name kind details+        ; 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)@@ -1875,10 +1861,30 @@ 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.  The skolem is rigid-(which we require for a quantified variable), but is still a TcTyVar that the-simplifier knows how to deal with.+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:@@ -2326,7 +2332,7 @@ *                                                                       * ************************************************************************* -See Note [Levity polymorphism checking] in DsMonad+See Note [Levity polymorphism checking] in GHC.HsToCore.Monad  -} @@ -2347,7 +2353,7 @@                    -- forall a. a. See, for example, test ghci/scripts/T9140     checkForLevPoly doc ty -  -- See Note [Levity polymorphism checking] in DsMonad+  -- See Note [Levity polymorphism checking] in GHC.HsToCore.Monad checkForLevPoly :: SDoc -> Type -> TcM () checkForLevPoly = checkForLevPolyX addErr
compiler/typecheck/TcMatches.hs view
@@ -48,7 +48,7 @@ import SrcLoc  -- Create chunkified tuple tybes for monad comprehensions-import MkCore+import GHC.Core.Make  import Control.Monad import Control.Arrow ( second )@@ -206,7 +206,7 @@           -> 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 { mc_what :: HsMatchContext GhcRn,  -- What kind of thing this is          mc_body :: Located (body GhcRn)         -- Type checker for a body of                                                 -- an alternative                  -> ExpRhoType@@ -291,7 +291,7 @@ ************************************************************************ -} -tcDoStmts :: HsStmtContext Name+tcDoStmts :: HsStmtContext GhcRn           -> Located [LStmt GhcRn (LHsExpr GhcRn)]           -> ExpRhoType           -> TcM (HsExpr GhcTcId)          -- Returns a HsDo@@ -338,13 +338,13 @@ type TcCmdStmtChecker  = TcStmtChecker HsCmd  TcRhoType  type TcStmtChecker body rho_type-  =  forall thing. HsStmtContext Name+  =  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 GhcTcId (Located (body GhcTcId)), thing) -tcStmts :: (Outputable (body GhcRn)) => HsStmtContext Name+tcStmts :: (Outputable (body GhcRn)) => HsStmtContext GhcRn         -> TcStmtChecker body rho_type   -- NB: higher-rank type         -> [LStmt GhcRn (Located (body GhcRn))]         -> rho_type@@ -354,7 +354,7 @@                         const (return ())        ; return stmts' } -tcStmtsAndThen :: (Outputable (body GhcRn)) => HsStmtContext Name+tcStmtsAndThen :: (Outputable (body GhcRn)) => HsStmtContext GhcRn                -> TcStmtChecker body rho_type    -- NB: higher-rank type                -> [LStmt GhcRn (Located (body GhcRn))]                -> rho_type@@ -972,7 +972,7 @@ -}  tcApplicativeStmts-  :: HsStmtContext Name+  :: HsStmtContext GhcRn   -> [(SyntaxExpr GhcRn, ApplicativeArg GhcRn)]   -> ExpRhoType                         -- rhs_ty   -> (TcRhoType -> TcM t)               -- thing_inside
compiler/typecheck/TcPat.hs view
@@ -48,7 +48,7 @@ import ConLike import PrelNames import BasicTypes hiding (SuccessFlag(..))-import DynFlags+import GHC.Driver.Session import SrcLoc import VarSet import Util@@ -82,7 +82,7 @@        ; tc_lpat pat pat_ty penv thing_inside }  ------------------tcPats :: HsMatchContext Name+tcPats :: HsMatchContext GhcRn        -> [LPat GhcRn]            -- Patterns,        -> [ExpSigmaType]         --   and their types        -> TcM a                  --   and the checker for the body@@ -104,14 +104,14 @@   where     penv = PE { pe_lazy = False, pe_ctxt = LamPat ctxt, pe_orig = PatOrigin } -tcPat :: HsMatchContext Name+tcPat :: HsMatchContext GhcRn       -> 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+tcPat_O :: HsMatchContext GhcRn         -> CtOrigin              -- ^ origin to use if the type needs inst'ing         -> LPat GhcRn -> ExpSigmaType         -> TcM a                 -- Checker for body@@ -138,7 +138,7 @@  data PatCtxt   = LamPat   -- Used for lambdas, case etc-       (HsMatchContext Name)+       (HsMatchContext GhcRn)    | LetPat   -- Used only for let(rec) pattern bindings              -- See Note [Typing patterns in pattern bindings]@@ -451,7 +451,7 @@   = 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+              -- See Note [Don't flatten tuples from HsSyn] in GHC.Core.Make         ; (coi, arg_tys) <- matchExpectedPatTy (matchExpectedTyConApp tc)                                                penv pat_ty                      -- Unboxed tuples have RuntimeRep vars, which we discard:@@ -604,8 +604,18 @@          ; res <- tcExtendIdEnv1 name bndr_id thing_inside -        ; let minus'' = minus' { syn_res_wrap =-                                    minus_wrap <.> syn_res_wrap minus' }+        ; let minus'' = case minus' of+                          NoSyntaxExprTc -> pprPanic "tc_pat NoSyntaxExprTc" (ppr minus')+                                   -- this should be statically avoidable+                                   -- Case (3) from Note [NoSyntaxExpr] in 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 (pat', res) }
compiler/typecheck/TcPatSyn.hs view
@@ -751,10 +751,9 @@                     , mg_origin = Generated                     } -       ; let bind = FunBind{ fun_ext = emptyNameSet-                           , fun_id = L loc matcher_id+       ; let bind = FunBind{ fun_id = L loc matcher_id                            , fun_matches = mg-                           , fun_co_fn = idHsWrapper+                           , fun_ext = idHsWrapper                            , fun_tick = [] }              matcher_bind = unitBag (noLoc bind) @@ -841,10 +840,9 @@          let match_group' | need_dummy_arg = add_dummy_arg match_group                           | otherwise      = match_group -             bind = FunBind { fun_ext = placeHolderNamesTc-                            , fun_id      = L loc (idName builder_id)+             bind = FunBind { fun_id      = L loc (idName builder_id)                             , fun_matches = match_group'-                            , fun_co_fn   = idHsWrapper+                            , fun_ext     = emptyNameSet                             , fun_tick    = [] }               sig = completeSigFromId (PatSynCtxt name) builder_id@@ -973,15 +971,15 @@                                          }     go1 (LitPat _ lit)              = return $ HsLit noExtField lit     go1 (NPat _ (L _ n) mb_neg _)-        | Just neg <- mb_neg        = return $ unLoc $ nlHsSyntaxApps neg-                                                     [noLoc (HsOverLit noExtField n)]+        | Just (SyntaxExprRn neg) <- mb_neg+                                    = return $ unLoc $ foldl' nlHsApp (noLoc 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@@ -994,7 +992,7 @@     go1 p@(SplicePat _ (HsTypedSplice {}))   = notInvertible p     go1 p@(SplicePat _ (HsUntypedSplice {})) = notInvertible p     go1 p@(SplicePat _ (HsQuasiQuote {}))    = notInvertible p-    go1 p@(SplicePat _ (XSplice {}))         = notInvertible p+    go1   (SplicePat _ (XSplice nec))        = noExtCon nec      notInvertible p = Left (not_invertible_msg p) @@ -1094,7 +1092,7 @@ 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+Any change to this ordering should make sure to change GHC.HsToCore.Expr if you want to avoid difficult to decipher core lint errors!  -}
compiler/typecheck/TcPluginM.hs view
@@ -58,7 +58,7 @@ import qualified TcMType   as TcM import qualified FamInst   as TcM import qualified GHC.Iface.Env as IfaceEnv-import qualified Finder+import qualified GHC.Driver.Finder as Finder  import FamInstEnv ( FamInstEnv ) import TcRnMonad  ( TcGblEnv, TcLclEnv, TcPluginM@@ -76,7 +76,7 @@ import TyCon import DataCon import Class-import HscTypes+import GHC.Driver.Types import Outputable import Type import Id
compiler/typecheck/TcRnDriver.hs view
@@ -62,10 +62,9 @@ import GHC.Rename.Expr import GHC.Rename.Utils  ( HsDocContext(..) ) import GHC.Rename.Fixity ( lookupFixityRn )-import MkId import TysWiredIn ( unitTy, mkListTy )-import Plugins-import DynFlags+import GHC.Driver.Plugins+import GHC.Driver.Session import GHC.Hs import GHC.Iface.Syntax ( ShowSub(..), showToHeader ) import GHC.Iface.Type   ( ShowForAllFlag(..) )@@ -81,8 +80,8 @@ import Constraint import TcOrigin import qualified BooleanFormula as BF-import PprTyThing( pprTyThingInContext )-import CoreFVs( orphNamesOfFamInst )+import GHC.Core.Ppr.TyThing ( pprTyThingInContext )+import GHC.Core.FVs         ( orphNamesOfFamInst ) import FamInst import InstEnv import FamInstEnv( FamInst, pprFamInst, famInstsRepTyCons@@ -119,7 +118,7 @@ import Avail import TyCon import SrcLoc-import HscTypes+import GHC.Driver.Types import ListSetOps import Outputable import ConLike@@ -166,7 +165,7 @@  tcRnModule hsc_env mod_sum save_rn_syntax    parsedModule@HsParsedModule {hpm_module= L loc this_module}- | RealSrcSpan real_loc <- loc+ | RealSrcSpan real_loc _ <- loc  = withTiming dflags               (text "Renamer/typechecker"<+>brackets (ppr this_mod))               (const ()) $@@ -1322,9 +1321,9 @@     <+> 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+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')@@ -1984,7 +1983,7 @@     traceTc "tcs 1" empty ;     this_mod <- getModule ;     global_ids <- mapM (externaliseAndTidyId this_mod) zonked_ids ;-        -- Note [Interactively-bound Ids in GHCi] in HscTypes+        -- Note [Interactively-bound Ids in GHCi] in GHC.Driver.Types  {- ---------------------------------------------    At one stage I removed any shadowed bindings from the type_env;@@ -2055,7 +2054,7 @@ -- -- 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+-- 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)@@ -2270,51 +2269,57 @@ -- 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] ;+ = 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 ;-         } ;+                                         (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 $+      ; traceTc "TcRnDriver.tcGhciStmts: tc stmts" empty+      ; ((tc_stmts, ids), lie) <- captureTopConstraints $                                   tc_io_stmts $ \ _ ->-                                  mapM tcLookupId names  ;+                                  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) ;+      ; 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) ;++      ; traceTc "TcRnDriver.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) $++      ; return (ids, mkHsDictLet (EvBinds const_binds) $                      noLoc (HsDo io_ret_ty GhciStmtCtxt (noLoc stmts)))     }
compiler/typecheck/TcRnDriver.hs-boot view
@@ -1,7 +1,6 @@ module TcRnDriver where  import GhcPrelude-import DynFlags (DynFlags) import Type (TyThing) import TcRnTypes (TcM) import Outputable (SDoc)@@ -10,4 +9,4 @@ 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+badReexportedBootThing :: Bool -> Name -> Name -> SDoc
compiler/typecheck/TcRnExports.hs view
@@ -28,7 +28,7 @@ import Avail import TyCon import SrcLoc-import HscTypes+import GHC.Driver.Types import Outputable import ConLike import DataCon@@ -39,7 +39,7 @@ import FastString (fsLit)  import Control.Monad-import DynFlags+import GHC.Driver.Session import GHC.Rename.Doc   ( rnHsDoc ) import RdrHsSyn         ( setRdrNameSpace ) import Data.Either      ( partitionEithers )@@ -176,9 +176,10 @@                  Just main_fun                      | is_main_mod -> mkUnqual varName (fsLit main_fun)                  _                 -> main_RDR_Unqual-        ; has_main <- lookupGlobalOccRn_maybe default_main >>= return . isJust-        -- If the module has no explicit header, and it has a main function,-        -- then we add a header like "module Main(main) where ..." (#13839)+        ; 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@@ -256,7 +257,7 @@  exports_from_avail (Just (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+       let final_exports = nubAvails (concatMap snd ie_avails) -- Combine families        return (Just ie_avails, final_exports)   where     do_litem :: ExportAccum -> LIE GhcPs@@ -451,12 +452,16 @@ For modules without a module header, this is implemented the following way: -If the module has a main function:-   Then create a module header and export the main function.+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'.@@ -844,6 +849,8 @@         = 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)+    (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"
compiler/typecheck/TcRnMonad.hs view
@@ -152,7 +152,7 @@ import TcOrigin  import GHC.Hs hiding (LIE)-import HscTypes+import GHC.Driver.Types import Module import RdrName import Name@@ -173,7 +173,7 @@ import Bag import Outputable import UniqSupply-import DynFlags+import GHC.Driver.Session import FastString import Panic import Util@@ -242,7 +242,7 @@                    -- We want to serialize the documentation in the .hi-files,                   -- and need to extract it from the renamed syntax first.-                  -- See 'ExtractDocs.extractDocs'.+                  -- See 'GHC.HsToCore.Docs.extractDocs'.                 | gopt Opt_Haddock dflags       = Just empty_val                  | keep_rn_syntax                = Just empty_val@@ -823,10 +823,10 @@  getSrcSpanM :: TcRn SrcSpan         -- Avoid clash with Name.getSrcLoc-getSrcSpanM = do { env <- getLclEnv; return (RealSrcSpan (tcl_loc env)) }+getSrcSpanM = do { env <- getLclEnv; return (RealSrcSpan (tcl_loc env) Nothing) }  setSrcSpan :: SrcSpan -> TcRn a -> TcRn a-setSrcSpan (RealSrcSpan real_loc) thing_inside+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@@ -1668,7 +1668,7 @@                   , cc_hole = TypeHole }        where          real_span = case nameSrcSpan name of-                           RealSrcSpan span  -> span+                           RealSrcSpan span _ -> span                            UnhelpfulSpan str -> pprPanic "emitNamedWildCardHoleConstraints"                                                       (ppr name <+> quotes (ftext str))                -- Wildcards are defined locally, and so have RealSrcSpans
compiler/typecheck/TcSMonad.hs view
@@ -129,7 +129,7 @@  import GhcPrelude -import HscTypes+import GHC.Driver.Types  import qualified Inst as TcM import InstEnv@@ -143,7 +143,7 @@        ( checkWellStaged, tcGetDefaultTys, tcLookupClass, tcLookupId, topIdLvl ) import ClsInst( InstanceWhat(..), safeOverlap, instanceReturnsDictCon ) import TcType-import DynFlags+import GHC.Driver.Session import Type import Coercion import Unify@@ -175,7 +175,7 @@ import UniqDFM import Maybes -import CoreMap+import GHC.Core.Map import Control.Monad import qualified Control.Monad.Fail as MonadFail import MonadUtils@@ -1530,14 +1530,21 @@ 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) }+  = do { ics <- getInertCans+       ; insts' <- add_qci (inert_insts ics)+       ; setInertCans (ics { inert_insts = insts' }) }   where-    add_qci :: [QCInst] -> [QCInst]+    add_qci :: [QCInst] -> TcS [QCInst]     -- See Note [Do not add duplicate quantified instances]-    add_qci qcis | any same_qci qcis = qcis-                 | otherwise         = new_qci : qcis+    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)) @@ -1557,7 +1564,7 @@ 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.+The simplest thing is simply to eliminate duplicates, which we do here. -}  {- *********************************************************************@@ -3023,6 +3030,7 @@   = 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) }
compiler/typecheck/TcSigs.hs view
@@ -41,7 +41,7 @@ import TcEvidence( HsWrapper, (<.>) ) import Type( mkTyVarBinders ) -import DynFlags+import GHC.Driver.Session import Var      ( TyVar, tyVarKind ) import Id       ( Id, idName, idType, idInlinePragma, setInlinePragma, mkLocalId ) import PrelNames( mkUnboundName )@@ -668,7 +668,7 @@   -From the TcSpecPrag, in DsBinds we generate a binding for f_spec and a RULE:+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<f rhs>
compiler/typecheck/TcSimplify.hs view
@@ -30,7 +30,7 @@  import Bag import Class         ( Class, classKey, classTyCon )-import DynFlags+import GHC.Driver.Session import Id            ( idType, mkLocalId ) import Inst import ListSetOps@@ -507,8 +507,8 @@  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+ 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]@@ -1799,7 +1799,7 @@  checkBadTelescope :: Implication -> TcS Bool -- True <=> the skolems form a bad telescope--- See Note [Keeping scoped variables in order: Explicit] in TcHsType+-- See Note [Checking telescopes] in Constraint checkBadTelescope (Implic { ic_telescope  = m_telescope                           , ic_skols      = skols })   | isJust m_telescope
compiler/typecheck/TcSplice.hs view
@@ -7,6 +7,7 @@ -}  {-# LANGUAGE CPP #-}+{-# LANGUAGE LambdaCase #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE ScopedTypeVariables #-}@@ -38,7 +39,7 @@  import GHC.Hs import Annotations-import Finder+import GHC.Driver.Finder import Name import TcRnMonad import TcType@@ -57,13 +58,14 @@  import GHCi.Message import GHCi.RemoteTypes-import GHCi-import HscMain+import GHC.Runtime.Interpreter+import GHC.Runtime.Interpreter.Types+import GHC.Driver.Main         -- These imports are the reason that TcSplice         -- is very high up the module hierarchy import GHC.Rename.Splice( traceSplice, SpliceInfo(..)) import RdrName-import HscTypes+import GHC.Driver.Types import GHC.ThToHs import GHC.Rename.Expr import GHC.Rename.Env@@ -86,7 +88,7 @@ import PrelNames import TysWiredIn import OccName-import Hooks+import GHC.Driver.Hooks import Var import Module import GHC.Iface.Load@@ -99,8 +101,8 @@ import TcEvidence import Id import IdInfo-import DsExpr-import DsMonad+import GHC.HsToCore.Expr+import GHC.HsToCore.Monad import GHC.Serialized import ErrUtils import Util@@ -111,19 +113,22 @@ import FastString import BasicTypes hiding( SuccessFlag(..) ) import Maybes( MaybeErr(..) )-import DynFlags+import GHC.Driver.Session import Panic import Lexeme import qualified EnumSet-import Plugins+import GHC.Driver.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 +#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@@ -135,7 +140,6 @@ import Data.Typeable ( typeOf, Typeable, TypeRep, typeRep ) import Data.Data (Data) import Data.Proxy    ( Proxy (..) )-import GHC.Exts         ( unsafeCoerce# )  {- ************************************************************************@@ -179,7 +183,7 @@        ; 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 DsMeta for desugaring+       -- 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,@@ -380,7 +384,7 @@   In both cases, desugaring happens like this:-  * HsTcBracketOut is desugared by DsMeta.dsBracket.  It+  * HsTcBracketOut is desugared by GHC.HsToCore.Quote.dsBracket.  It        a) Extends the ds_meta environment with the PendingSplices          attached to the bracket@@ -395,10 +399,10 @@     ${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+  * 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 (DsMeta.repSplice).+    it just desugars it to get a CoreExpr (GHC.HsToCore.Quote.repSplice).  Example:     Source:       f = [| Just $(g 3) |]@@ -511,7 +515,7 @@ during compilation:  1. Typechecking nested splices (immediately in tcPendingSplice)-2. Desugaring quotations (see DsMeta)+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@@ -641,7 +645,7 @@        ; lcl_env <- getLclEnv        ; let delayed_splice               = DelayedSplice lcl_env expr res_ty q_expr-       ; return (HsSpliceE noExtField (HsSplicedT delayed_splice))+       ; return (HsSpliceE noExtField (XSplice (HsSplicedT delayed_splice)))         } @@ -770,14 +774,14 @@  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+  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+        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@@ -791,6 +795,7 @@ seqSerialized :: Serialized -> () seqSerialized (Serialized the_type bytes) = the_type `seq` bytes `seqList` () +#endif  {- ************************************************************************@@ -805,13 +810,18 @@  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+  interp <- tcGetInterp+  case interp of+#if defined(HAVE_INTERNAL_INTERPRETER)+    InternalInterp -> do+      qs <- liftIO (withForeignRefs finRefs $ mapM localRef)+      runQuasi $ sequence_ qs+#endif++    ExternalInterp iserv -> withIServ_ iserv $ \i -> do       tcg <- getGblEnv       th_state <- readTcRef (tcg_th_remote_state tcg)       case th_state of@@ -822,9 +832,6 @@               writeIServ i (putMessage (RunModFinalizers st qrefs))           () <- runRemoteTH i []           readQResult i-  else do-    qs <- liftIO (withForeignRefs finRefs $ mapM localRef)-    runQuasi $ sequence_ qs  runQResult   :: (a -> String)@@ -915,7 +922,7 @@         ; src_span <- getSrcSpanM         ; traceTc "About to run (desugared)" (ppr ds_expr)         ; either_hval <- tryM $ liftIO $-                         HscMain.hscCompileCoreExpr hsc_env src_span ds_expr+                         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@@ -1079,7 +1086,7 @@                  ; r <- case l of                         UnhelpfulSpan _ -> pprPanic "qLocation: Unhelpful location"                                                     (ppr l)-                        RealSrcSpan s -> return s+                        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)@@ -1159,7 +1166,7 @@       addModFinalizerRef fref    qAddCorePlugin plugin = do-      hsc_env <- env_top <$> getEnv+      hsc_env <- getTopEnv       r <- liftIO $ findHomeModule hsc_env (mkModuleName plugin)       let err = hang             (text "addCorePlugin: invalid plugin module "@@ -1206,11 +1213,17 @@ -- | 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+  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 @@ -1225,19 +1238,21 @@  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+  interp <- tcGetInterp+  case interp of+#if defined(HAVE_INTERNAL_INTERPRETER)+    InternalInterp -> do        -- Run it in the local TcM-      hv <- liftIO $ wormhole dflags fhv-      r <- runQuasi (unsafeCoerce# hv :: TH.Q a)+      hv <- liftIO $ wormhole InternalInterp fhv+      r <- runQuasi (unsafeCoerce hv :: TH.Q a)       return r-    else+#endif++    ExternalInterp 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 hsc_env $ \i -> do+      withIServ_ iserv $ \i -> do         rstate <- getTHState i         loc <- TH.qLocation         liftIO $@@ -1252,7 +1267,7 @@ -- | communicate with a remotely-running TH computation until it finishes. -- See Note [Remote Template Haskell] in libraries/ghci/GHCi/TH.hs. runRemoteTH-  :: IServ+  :: IServInstance   -> [Messages]   --  saved from nested calls to qRecover   -> TcM () runRemoteTH iserv recovers = do@@ -1281,7 +1296,7 @@       runRemoteTH iserv recovers  -- | Read a value of type QResult from the iserv-readQResult :: Binary a => IServ -> TcM a+readQResult :: Binary a => IServInstance -> TcM a readQResult i = do   qr <- liftIO $ readIServ i get   case qr of@@ -1330,14 +1345,14 @@ -- -- The TH state is stored in tcg_th_remote_state in the TcGblEnv. ---getTHState :: IServ -> TcM (ForeignRef (IORef QState))+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 <- env_top <$> getEnv+      hsc_env <- getTopEnv       fhv <- liftIO $ mkFinalizedHValue hsc_env =<< iservCall i StartTH       writeTcRef (tcg_th_remote_state tcg) (Just fhv)       return fhv@@ -1366,7 +1381,7 @@   AddDependentFile f -> wrapTHResult $ TH.qAddDependentFile f   AddTempFile s -> wrapTHResult $ TH.qAddTempFile s   AddModFinalizer r -> do-    hsc_env <- env_top <$> getEnv+    hsc_env <- getTopEnv     wrapTHResult $ liftIO (mkFinalizedHValue hsc_env r) >>= addModFinalizerRef   AddCorePlugin str -> wrapTHResult $ TH.qAddCorePlugin str   AddTopDecls decs -> wrapTHResult $ TH.qAddTopDecls decs@@ -2361,3 +2376,10 @@ 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
compiler/typecheck/TcTyClsDecls.hs view
@@ -6,7 +6,7 @@ TcTyClsDecls: Typecheck type and class declarations -} -{-# LANGUAGE CPP, TupleSections, MultiWayIf #-}+{-# LANGUAGE CPP, TupleSections, ScopedTypeVariables, MultiWayIf #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} @@ -29,7 +29,7 @@ import GhcPrelude  import GHC.Hs-import HscTypes+import GHC.Driver.Types import BuildTyCl import TcRnMonad import TcEnv@@ -71,7 +71,7 @@ import Util import SrcLoc import ListSetOps-import DynFlags+import GHC.Driver.Session import Unique import ConLike( ConLike(..) ) import BasicTypes@@ -80,11 +80,12 @@ 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 )  {- ************************************************************************@@ -433,6 +434,108 @@  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.@@ -571,107 +674,227 @@         -- Finally, go through each tycon and give it its final kind,         -- with all the required, specified, and inferred variables         -- in order.-        ; generalized_tcs <- mapAndReportM generaliseTcTyCon inferred_tcs+        ; 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) -generaliseTcTyCon :: TcTyCon -> TcM TcTyCon-generaliseTcTyCon tc-  -- See Note [Required, Specified, and Inferred for types]-  = setSrcSpan (getSrcSpan tc) $-    addTyConCtxt tc $-    do { let tc_name      = tyConName tc-             tc_res_kind  = tyConResKind tc-             spec_req_prs = tcTyConScopedTyVars 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 -             (spec_req_names, spec_req_tvs) = unzip spec_req_prs-             -- NB: spec_req_tvs includes both Specified and Required-             -- Running example in Note [Inferring kinds for type declarations]-             --    spec_req_prs = [ ("k1",kk1), ("a", (aa::kk1))-             --                   , ("k2",kk2), ("x", (xx::kk2))]-             -- where "k1" denotes the Name k1, and kk1, aa, etc are MetaTyVars,-             -- specifically TyVarTvs+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 -       -- Step 0: zonk and skolemise the Specified and Required binders-       -- It's essential that they are skolems, not MetaTyVars,-       -- for Step 3 to work right-       ; spec_req_tvs <- mapM zonkAndSkolemise spec_req_tvs-             -- Running example, where kk1 := kk2, so we get-             --   [kk2,kk2]+       -- Extract the specified/required binders and skolemise them+       ; tc_with_tvs  <- mapM skolemise_tc_tycon names_in_this_decl -       -- Step 1: 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-       ; checkDuplicateTyConBinders spec_req_names spec_req_tvs+       -- 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-       -- NB: candidateQTyVarsOfKinds zonks as it goes        ; dvs1 <- candidateQTyVarsOfKinds $-                (tc_res_kind : map tyVarKind spec_req_tvs)+                 (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 -       -- Step 3a: rename all the Specified and Required tyvars back to-       -- TyVars with their oroginal user-specified name.  Example-       --     class C a_r23 where ....-       -- By this point we have scoped_prs = [(a_r23, a_r89[TyVarTv])]-       -- We return with the TyVar a_r23[TyVar],-       --    and ze mapping a_r89 :-> a_r23[TyVar]-       ; traceTc "generaliseTcTyCon: before zonkRec"-           (vcat [ text "spec_req_tvs =" <+> pprTyVars spec_req_tvs+       ; 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 ])-       ; (ze, final_spec_req_tvs) <- zonkRecTyVarBndrs spec_req_names spec_req_tvs-           -- So ze maps from the tyvars that have ended up -       -- Step 3b: Apply that mapping to the other variables-       -- (remember they all started as TyVarTvs).-       -- They have been skolemised by quantifyTyVars.-       ; (ze, inferred) <- zonkTyBndrsX ze inferred-       ; tc_res_kind    <- zonkTcTypeToTypeX ze tc_res_kind+       -- 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 "ze =" <+> ppr ze-              , text "spec_req_prs =" <+> ppr spec_req_prs               , text "spec_req_tvs =" <+> pprTyVars spec_req_tvs-              , text "final_spec_req_tvs =" <+> pprTyVars final_spec_req_tvs ]--       -- Step 4: Find the Specified and Inferred 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 n_spec        = length final_spec_req_tvs - tyConArity tc-             (spec_tvs, req_tvs) = splitAt n_spec final_spec_req_tvs-             specified     = scopedSort spec_tvs-                             -- NB: maintain the L-R order of scoped_tvs+              , text "sorted_spec_tvs =" <+> pprTyVars sorted_spec_tvs+              , text "req_tvs =" <+> ppr req_tvs+              , text "zonk-env =" <+> ppr ze ] -       -- Step 5: Make the TyConBinders.-             to_user tv     = lookupTyVarOcc ze tv `orElse` tv-             dep_fv_set     = mapVarSet to_user (candidateKindVars dvs1)+       -- Step 4: Make the TyConBinders.+       ; let dep_fv_set     = candidateKindVars dvs1              inferred_tcbs  = mkNamedTyConBinders Inferred inferred-             specified_tcbs = mkNamedTyConBinders Specified specified+             specified_tcbs = mkNamedTyConBinders Specified sorted_spec_tvs              required_tcbs  = map (mkRequiredTyConBinder dep_fv_set) req_tvs -       -- Step 6: Assemble the final list.+       -- Step 5: Assemble the final list.              final_tcbs = concat [ inferred_tcbs                                  , specified_tcbs                                  , required_tcbs ] -       -- Step 7: Make the result TcTyCon-             tycon = mkTcTyCon tc_name final_tcbs tc_res_kind-                            (mkTyVarNamePairs final_spec_req_tvs)+       -- 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) @@ -679,32 +902,18 @@          vcat [ text "tycon =" <+> ppr tc               , text "tc_res_kind =" <+> ppr tc_res_kind               , text "dep_fv_set =" <+> ppr dep_fv_set-              , text "final_spec_req_tvs =" <+> pprTyVars final_spec_req_tvs-              , text "inferred =" <+> pprTyVars inferred-              , text "specified =" <+> pprTyVars specified+              , 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 8: Check for validity.+       -- 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 } -checkDuplicateTyConBinders :: [Name] -> [TcTyVar] -> TcM ()-checkDuplicateTyConBinders spec_req_names spec_req_tvs-  | null dups = return ()-  | otherwise = mapM_ report_dup dups >> failM-  where-    dups :: [(Name,Name)]-    dups = findDupTyVarTvs $ spec_req_names `zip` spec_req_tvs--    report_dup (n1, n2)-      = setSrcSpan (getSrcSpan n2) $-        addErrTc (text "Couldn't match" <+> quotes (ppr n1)-                        <+> text "with" <+> quotes (ppr n2))- {- Note [Required, Specified, and Inferred for types] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Each forall'd type variable in a type or kind is one of@@ -1029,8 +1238,8 @@ mk_prom_err_env (ClassDecl { tcdLName = L _ nm, tcdATs = ats })   = unitNameEnv nm (APromotionErr ClassPE)     `plusNameEnv`-    mkNameEnv [ (name, APromotionErr TyConPE)-              | (L _ (FamilyDecl { fdLName = L _ name })) <- ats ]+    mkNameEnv [ (familyDeclName at, APromotionErr TyConPE)+              | L _ at <- ats ]  mk_prom_err_env (DataDecl { tcdLName = L _ name                           , tcdDataDefn = HsDataDefn { dd_cons = cons } })@@ -1770,17 +1979,14 @@                      , tcdRhs   = rhs })   = ASSERT( isNothing _parent )     fmap noDerivInfos $-    bindTyClTyVars tc_name $ \ binders res_kind ->-    tcTySynRhs roles_info tc_name binders res_kind rhs+    tcTySynRhs roles_info tc_name rhs    -- "data/newtype" declaration tcTyClDecl1 _parent roles_info             decl@(DataDecl { tcdLName = L _ tc_name                            , tcdDataDefn = defn })   = ASSERT( isNothing _parent )-    bindTyClTyVars tc_name $ \ tycon_binders res_kind ->-    tcDataDefn (tcMkDeclCtxt decl) roles_info tc_name-               tycon_binders res_kind defn+    tcDataDefn (tcMkDeclCtxt decl) roles_info tc_name defn  tcTyClDecl1 _parent roles_info             (ClassDecl { tcdLName = L _ class_name@@ -1884,10 +2090,10 @@        ; mapM tc_at ats }   where     at_def_tycon :: LTyFamDefltDecl GhcRn -> Name-    at_def_tycon (L _ eqn) = tyFamInstDeclName eqn+    at_def_tycon = tyFamInstDeclName . unLoc      at_fam_name :: LFamilyDecl GhcRn -> Name-    at_fam_name (L _ decl) = unLoc (fdLName decl)+    at_fam_name = familyDeclName . unLoc      at_names = mkNameSet (map at_fam_name ats) @@ -2226,12 +2432,11 @@                                        , ppr inj_ktvs, ppr inj_bools ])        ; return $ Injective inj_bools } -tcTySynRhs :: RolesInfo-           -> Name-           -> [TyConBinder] -> Kind+tcTySynRhs :: RolesInfo -> Name            -> LHsType GhcRn -> TcM TyCon-tcTySynRhs roles_info tc_name binders res_kind hs_ty-  = do { env <- getLclEnv+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 $@@ -2241,27 +2446,29 @@              tycon = buildSynTyCon tc_name binders res_kind roles rhs_ty        ; return tycon } -tcDataDefn :: SDoc-           -> RolesInfo -> Name-           -> [TyConBinder] -> Kind+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 tycon_binders res_kind+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 })- =  do { gadt_syntax <- dataDeclChecks tc_name new_or_data ctxt cons+  = 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-       ; (extra_bndrs, final_res_kind) <- etaExpandAlgTyCon tycon_binders res_kind        ; let hsc_src = tcg_src tcg_env        ; unless (mk_permissive_kind hsc_src cons) $-           checkDataKindSig (DataDeclSort new_or_data) final_res_kind+         checkDataKindSig (DataDeclSort new_or_data) final_res_kind         ; stupid_tc_theta <- pushTcLevelM_ $ solveEqualities $ tcHsContext ctxt        ; stupid_theta    <- zonkTcTypesToTypes stupid_tc_theta@@ -2326,7 +2533,7 @@           DataType -> return (mkDataTyConRhs data_cons)           NewType  -> ASSERT( not (null data_cons) )                       mkNewTyConRhs tc_name tycon (head data_cons)-tcDataDefn _ _ _ _ _ (XHsDataDefn nec) = noExtCon nec+tcDataDefn _ _ _ (XHsDataDefn nec) = noExtCon nec   -------------------------@@ -2382,7 +2589,13 @@                                       , feqn_rhs    = hs_rhs_ty }}))   = ASSERT( getName fam_tc == eqn_tc_name )     setSrcSpan loc $-    do {+    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.@@ -2466,7 +2679,7 @@                    -> 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 {" (vcat [ ppr fam_tc <+> ppr hs_pats ])+  = 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@@ -2495,6 +2708,13 @@        ; 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@@ -2817,7 +3037,7 @@                  ; return (ctxt, final_arg_tys, res_ty, field_lbls, stricts)                  }        ; imp_tvs <- zonkAndScopedSort imp_tvs-       ; let user_tvs      = imp_tvs ++ exp_tvs+       ; let user_tvs = imp_tvs ++ exp_tvs         ; tkvs <- kindGeneralizeAll (mkSpecForAllTys user_tvs $                                     mkPhiTy ctxt $@@ -3736,7 +3956,7 @@            -- method in a dictionary            -- example of what this prevents:            --   class BoundedX (a :: TYPE r) where minBound :: a-           -- See Note [Levity polymorphism checking] in DsMonad+           -- See Note [Levity polymorphism checking] in GHC.HsToCore.Monad         ; checkForLevPoly empty tau1          ; unless constrained_class_methods $@@ -4112,7 +4332,7 @@ -- -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+-- See Note [GHC Formalism] in GHC.Core.Lint checkValidRoles tc   | isAlgTyCon tc     -- tyConDataCons returns an empty list for data families
compiler/typecheck/TcTyDecls.hs view
@@ -40,11 +40,11 @@ import TcType import Predicate import TysWiredIn( unitTy )-import MkCore( rEC_SEL_ERROR_ID )+import GHC.Core.Make( rEC_SEL_ERROR_ID ) import GHC.Hs import Class import Type-import HscTypes+import GHC.Driver.Types import TyCon import ConLike import DataCon@@ -138,7 +138,6 @@      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
compiler/typecheck/TcTypeable.hs view
@@ -21,7 +21,7 @@ import TcEvidence ( mkWpTyApps ) import TcRnMonad import TcType-import HscTypes ( lookupId )+import GHC.Driver.Types ( lookupId ) import PrelNames import TysPrim ( primTyCons ) import TysWiredIn ( tupleTyCon, sumTyCon, runtimeRepTyCon@@ -34,10 +34,10 @@ import DataCon import Module import GHC.Hs-import DynFlags+import GHC.Driver.Session import Bag import Var ( VarBndr(..) )-import CoreMap+import GHC.Core.Map import Constants import Fingerprint(Fingerprint(..), fingerprintString, fingerprintFingerprints) import Outputable
compiler/typecheck/TcUnify.hs view
@@ -64,7 +64,7 @@ import VarSet import VarEnv import ErrUtils-import DynFlags+import GHC.Driver.Session import BasicTypes import Bag import Util@@ -1768,6 +1768,10 @@ Given (a ~ b), should we orient the CTyEqCan as (a~b) or (b~a)? This is a surprisingly tricky question! +The question is answered by swapOverTyVars, which is use+  - in the eager unifier, in TcUnify.uUnfilledVar1+  - in the constraint solver, in TcCanonical.canEqTyVarHomo+ First note: only swap if you have to!    See Note [Avoid unnecessary swaps] @@ -1777,25 +1781,31 @@   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'+  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+  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, TcSimplify.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] -  - TyVarTv/TauTv: if we have  tyv_tv ~ tau_tv, put tau_tv-                   on the left because there are fewer-                   restrictions on updating TauTvs+        NB: FlatMetaTvs always have the current level, never an+        outer one.  So nothing can be deeper than a FlatMetaTv. -  - 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+  - 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 -  - FlatSkolTv: Put on the left in preference to a SkolemTv-                See Note [Eliminate flat-skols]+  - 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
compiler/typecheck/TcValidity.hs view
@@ -61,7 +61,7 @@ import Var         ( VarBndr(..), mkTyVar ) import FV import ErrUtils-import DynFlags+import GHC.Driver.Session import Util import ListSetOps import SrcLoc@@ -1931,7 +1931,7 @@                                -- See Note [Invisible arguments and termination]           ForAllPred tvs _ head_pred'-           -> check (foralld_tvs `extendVarSetList` binderVars 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 @@ -2712,7 +2712,7 @@  See also   * Note [Required, Specified, and Inferred for types] in TcTyClsDecls.-  * Note [Keeping scoped variables in order: Explicit] discusses how+  * Note [Checking telescopes] in Constraint discusses how     this check works for `forall x y z.` written in a type.  Note [Ambiguous kind vars]@@ -2838,7 +2838,7 @@ fvType (CoercionTy {})       = []  fvTypes :: [Type] -> [TyVar]-fvTypes tys                = concat (map fvType tys)+fvTypes tys                = concatMap fvType tys  sizeType :: Type -> Int -- Size of a type: the number of variables and constructors
compiler/utils/AsmUtils.hs view
@@ -1,7 +1,7 @@ -- | Various utilities used in generating assembler. -- -- These are used not only by the native code generator, but also by the--- "DriverPipeline".+-- GHC.Driver.Pipeline module AsmUtils     ( sectionType     ) where
− compiler/utils/Dominators.hs 
@@ -1,597 +0,0 @@-{-# LANGUAGE RankNTypes, BangPatterns, FlexibleContexts, Strict #-}
-
-{- |
-  Module      :  Dominators
-  Copyright   :  (c) Matt Morrow 2009
-  License     :  BSD3
-  Maintainer  :  <morrow@moonpatio.com>
-  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)
-
compiler/utils/GraphColor.hs view
@@ -324,7 +324,7 @@         -- the prefs of our neighbors         colors_neighbor_prefs                         = mkUniqSet-                        $ concat $ map nodePreference nsConflicts+                        $ concatMap nodePreference nsConflicts          -- colors that are still valid for us         colors_ok_ex    = minusUniqSet colors_avail (nodeExclusions node)
compiler/utils/GraphPpr.hs view

file too large to diff

ghc-lib.cabal view

file too large to diff

ghc-lib/stage0/compiler/build/primop-data-decl.hs-incl view

file too large to diff

ghc-lib/stage0/compiler/build/primop-has-side-effects.hs-incl view

file too large to diff

ghc-lib/stage0/compiler/build/primop-list.hs-incl view

file too large to diff

ghc-lib/stage0/compiler/build/primop-out-of-line.hs-incl view

file too large to diff

ghc-lib/stage0/compiler/build/primop-primop-info.hs-incl view

file too large to diff

ghc-lib/stage0/compiler/build/primop-strictness.hs-incl view

file too large to diff

ghc-lib/stage0/compiler/build/primop-tag.hs-incl view

file too large to diff

ghc-lib/stage0/lib/ghcversion.h view

file too large to diff

ghc-lib/stage0/lib/llvm-targets view

file too large to diff

includes/CodeGen.Platform.hs view

file too large to diff

libraries/template-haskell/Language/Haskell/TH/Quote.hs view

file too large to diff